module Graphics.GPipe.Internal.Context
(
ContextFactory,
ContextHandle(..),
ContextT(),
GPipeException(..),
runContextT,
runSharedContextT,
liftContextIO,
liftContextIOAsync,
addContextFinalizer,
getContextFinalizerAdder,
getRenderContextFinalizerAdder ,
swapContextBuffers,
withContextWindow,
addVAOBufferFinalizer,
addFBOTextureFinalizer,
getContextData,
getRenderContextData,
getVAO, setVAO,
getFBO, setFBO,
ContextData,
VAOKey(..), FBOKey(..), FBOKeys(..),
Render(..), render, getContextBuffersSize,
registerRenderWriteTexture
)
where
import Graphics.GPipe.Internal.Format
import Control.Monad.Exception (MonadException, Exception, MonadAsyncException,bracket)
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Applicative (Applicative, (<$>))
import Data.Typeable (Typeable)
import qualified Data.IntSet as Set
import qualified Data.Map.Strict as Map
import Graphics.GL.Core33
import Graphics.GL.Types
import Control.Concurrent.MVar
import Data.IORef
import Control.Monad
import Data.List (delete)
import Foreign.C.Types
import Data.Maybe (maybeToList)
import Linear.V2 (V2(V2))
import Control.Monad.Trans.Error
import Control.Exception (throwIO)
import Control.Monad.Trans.State.Strict
type ContextFactory c ds w = ContextFormat c ds -> IO (ContextHandle w)
data ContextHandle w = ContextHandle {
newSharedContext :: forall c ds. ContextFormat c ds -> IO (ContextHandle w),
contextDoSync :: forall a. IO a -> IO a,
contextDoAsync :: IO () -> IO (),
contextSwap :: IO (),
contextFrameBufferSize :: IO (Int, Int),
contextDelete :: IO (),
contextWindow :: w
}
newtype ContextT w os f m a =
ContextT (ReaderT (ContextHandle w, (ContextData, SharedContextDatas)) m a)
deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException)
instance MonadTrans (ContextT w os f) where
lift = ContextT . lift
runContextT :: (MonadIO m, MonadAsyncException m) => ContextFactory c ds w -> ContextFormat c ds -> (forall os. ContextT w os (ContextFormat c ds) m a) -> m a
runContextT cf f (ContextT m) =
bracket
(liftIO $ cf f)
(liftIO . contextDelete)
$ \ h -> do cds <- liftIO newContextDatas
cd <- liftIO $ addContextData cds
let ContextT i = initGlState
rs = (h, (cd, cds))
runReaderT (i >> m) rs
runSharedContextT :: (MonadIO m, MonadAsyncException m) => ContextFormat c ds -> ContextT w os (ContextFormat c ds) (ContextT w os f m) a -> ContextT w os f m a
runSharedContextT f (ContextT m) =
bracket
(do (h',(_,cds)) <- ContextT ask
h <- liftIO $ newSharedContext h' f
cd <- liftIO $ addContextData cds
return (h,cd)
)
(\(h,cd) -> do cds <- ContextT $ asks (snd . snd)
liftIO $ do removeContextData cds cd
contextDelete h)
$ \(h,cd) -> do cds <- ContextT $ asks (snd . snd)
let ContextT i = initGlState
rs = (h, (cd, cds))
runReaderT (i >> m) rs
initGlState :: MonadIO m => ContextT w os f m ()
initGlState = liftContextIOAsync $ do glEnable GL_FRAMEBUFFER_SRGB
glEnable GL_SCISSOR_TEST
glPixelStorei GL_PACK_ALIGNMENT 1
glPixelStorei GL_UNPACK_ALIGNMENT 1
liftContextIO :: MonadIO m => IO a -> ContextT w os f m a
liftContextIO m = ContextT (asks fst) >>= liftIO . flip contextDoSync m
addContextFinalizer :: MonadIO m => IORef a -> IO () -> ContextT w os f m ()
addContextFinalizer k m = ContextT (asks fst) >>= liftIO . void . mkWeakIORef k . flip contextDoAsync m
getContextFinalizerAdder :: MonadIO m => ContextT w os f m (IORef a -> IO () -> IO ())
getContextFinalizerAdder = do h <- ContextT (asks fst)
return $ \k m -> void $ mkWeakIORef k (contextDoAsync h m)
liftContextIOAsync :: MonadIO m => IO () -> ContextT w os f m ()
liftContextIOAsync m = ContextT (asks fst) >>= liftIO . flip contextDoAsync m
swapContextBuffers :: MonadIO m => ContextT w os f m ()
swapContextBuffers = ContextT (asks fst) >>= (\c -> liftIO $ contextSwap c)
type ContextDoAsync = IO () -> IO ()
newtype Render os f a = Render (ErrorT String (StateT Set.IntSet (ReaderT (ContextDoAsync, (ContextData, SharedContextDatas)) IO)) a) deriving (Monad, Applicative, Functor)
render :: (MonadIO m, MonadException m) => Render os f () -> ContextT w os f m ()
render (Render m) = do c <- ContextT ask
eError <- liftIO $ contextDoSync (fst c) $ runReaderT (evalStateT (runErrorT m) Set.empty) (contextDoAsync (fst c), snd c)
case eError of
Left s -> liftIO $ throwIO $ GPipeException s
_ -> return ()
registerRenderWriteTexture :: Int -> Render os f ()
registerRenderWriteTexture x = Render $ lift $ modify $ Set.insert x
getContextBuffersSize :: MonadIO m => ContextT w os f m (V2 Int)
getContextBuffersSize = ContextT $ do c <- asks fst
(x,y) <- liftIO $ contextFrameBufferSize c
return $ V2 x y
withContextWindow :: MonadIO m => (w -> IO a) -> ContextT w os f m a
withContextWindow f= ContextT $ do c <- asks fst
liftIO $ contextDoSync c $ f (contextWindow c)
getRenderContextFinalizerAdder :: Render os f (IORef a -> IO () -> IO ())
getRenderContextFinalizerAdder = do f <- Render (lift $ lift $ asks fst)
return $ \k m -> void $ mkWeakIORef k (f m)
data GPipeException = GPipeException String
deriving (Show, Typeable)
instance Exception GPipeException
type SharedContextDatas = MVar [ContextData]
type ContextData = MVar (VAOCache, FBOCache)
data VAOKey = VAOKey { vaoBname :: !GLuint, vaoCombBufferOffset :: !Int, vaoComponents :: !GLint, vaoNorm :: !Bool, vaoDiv :: !Int } deriving (Eq, Ord)
data FBOKey = FBOKey { fboTname :: !GLuint, fboTlayerOrNegIfRendBuff :: !Int, fboTlevel :: !Int } deriving (Eq, Ord)
data FBOKeys = FBOKeys { fboColors :: [FBOKey], fboDepth :: Maybe FBOKey, fboStencil :: Maybe FBOKey } deriving (Eq, Ord)
type VAOCache = Map.Map [VAOKey] (IORef GLuint)
type FBOCache = Map.Map FBOKeys (IORef GLuint)
getFBOKeys :: FBOKeys -> [FBOKey]
getFBOKeys (FBOKeys xs d s) = xs ++ maybeToList d ++ maybeToList s
newContextDatas :: IO (MVar [ContextData])
newContextDatas = newMVar []
addContextData :: SharedContextDatas -> IO ContextData
addContextData r = do cd <- newMVar (Map.empty, Map.empty)
modifyMVar_ r $ return . (cd:)
return cd
removeContextData :: SharedContextDatas -> ContextData -> IO ()
removeContextData r cd = modifyMVar_ r $ return . delete cd
addCacheFinalizer :: MonadIO m => (GLuint -> (VAOCache, FBOCache) -> (VAOCache, FBOCache)) -> IORef GLuint -> ContextT w os f m ()
addCacheFinalizer f r = ContextT $ do cds <- asks (snd . snd)
liftIO $ do n <- readIORef r
void $ mkWeakIORef r $ do cs' <- readMVar cds
mapM_ (`modifyMVar_` (return . f n)) cs'
addVAOBufferFinalizer :: MonadIO m => IORef GLuint -> ContextT w os f m ()
addVAOBufferFinalizer = addCacheFinalizer deleteVAOBuf
where deleteVAOBuf n (vao, fbo) = (Map.filterWithKey (\k _ -> all ((/=n) . vaoBname) k) vao, fbo)
addFBOTextureFinalizer :: MonadIO m => Bool -> IORef GLuint -> ContextT w os f m ()
addFBOTextureFinalizer isRB = addCacheFinalizer deleteVBOBuf
where deleteVBOBuf n (vao, fbo) = (vao, Map.filterWithKey
(\ k _ ->
all
(\ fk ->
fboTname fk /= n || isRB /= (fboTlayerOrNegIfRendBuff fk < 0))
$ getFBOKeys k)
fbo)
getContextData :: MonadIO m => ContextT w os f m ContextData
getContextData = ContextT $ asks (fst . snd)
getRenderContextData :: Render os f ContextData
getRenderContextData = Render $ lift $ lift $ asks (fst . snd)
getVAO :: ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint))
getVAO cd k = do (vaos, _) <- readMVar cd
return (Map.lookup k vaos)
setVAO :: ContextData -> [VAOKey] -> IORef GLuint -> IO ()
setVAO cd k v = modifyMVar_ cd $ \ (vaos, fbos) -> return (Map.insert k v vaos, fbos)
getFBO :: ContextData -> FBOKeys -> IO (Maybe (IORef GLuint))
getFBO cd k = do (_, fbos) <- readMVar cd
return (Map.lookup k fbos)
setFBO :: ContextData -> FBOKeys -> IORef GLuint -> IO ()
setFBO cd k v = modifyMVar_ cd $ \(vaos, fbos) -> return (vaos, Map.insert k v fbos)