module Graphics.GPipe.Context.GLFW
(
newContext,
newContext',
BadWindowHintsException(..),
GLFWWindow(),
WindowConf(..), defaultWindowConf,
module Input
) where
import qualified Graphics.GPipe.Context.GLFW.Format as Format
import Graphics.GPipe.Context.GLFW.Input as Input
import qualified Graphics.GPipe.Context.GLFW.Resource as Resource
import Graphics.GPipe.Context.GLFW.Resource (WindowConf, defaultWindowConf, GLFWWindow(..))
import qualified Graphics.GPipe.Context.GLFW.Util as Util
import qualified Control.Concurrent as C
import qualified Graphics.UI.GLFW as GLFW (makeContextCurrent, destroyWindow, pollEvents)
import Graphics.GPipe.Context (ContextFactory, ContextHandle(..))
import Graphics.UI.GLFW (WindowHint(..))
import Data.IORef
import Control.Monad (when, unless)
import Control.Exception (Exception, throwIO)
import Data.Typeable (Typeable)
data Message where
ReqShutDown :: C.MVar () -> Message
ReqExecuteSync :: forall a. IO a -> C.MVar a -> Message
ReqExecuteAsync :: IO () -> Message
data BadWindowHintsException = BadWindowHintsException [WindowHint]
deriving (Show, Typeable)
instance Exception BadWindowHintsException
newContext :: ContextFactory c ds GLFWWindow
newContext = newContext' [] defaultWindowConf
newContext' :: [WindowHint] -> WindowConf -> ContextFactory c ds GLFWWindow
newContext' extraHints conf fmt = do
let badHints = filter (not . allowedHint) extraHints
unless (null badHints) $
throwIO (BadWindowHintsException badHints)
chReply <- C.newEmptyMVar
_ <- C.forkOS $ begin chReply
msgC <- C.takeMVar chReply
h <- createContext extraHints conf msgC Nothing fmt
contextDoAsync h True (return ())
return h
createContext :: [WindowHint] -> WindowConf -> C.Chan Message -> Maybe Resource.Window -> ContextFactory c ds GLFWWindow
createContext extraHints conf msgC share fmt = do
w <- makeContext share
GLFW.makeContextCurrent Nothing
alive <- newIORef True
return ContextHandle
{ newSharedContext = mainthreadDoWhileContextUncurrent msgC w . createContext extraHints conf msgC (Just w)
, contextDoSync = contextDoSyncImpl w msgC
, contextDoAsync = contextDoAsyncImpl alive w msgC
, contextSwap = contextDoSyncImpl w msgC False $ Util.swapBuffers w
, contextFrameBufferSize = Util.getFramebufferSize w
, contextDelete = case share of
Nothing -> do contextDeleteImpl msgC
GLFW.destroyWindow w
Just parentW -> mainthreadDoWhileContextUncurrent msgC parentW (writeIORef alive False >> GLFW.destroyWindow w)
, contextWindow = GLFWWindow w
}
where
hints = Format.toHints fmt ++ extraHints
makeContext :: Maybe Resource.Window -> IO Resource.Window
makeContext Nothing = Resource.newContext Nothing hints (Just conf)
makeContext (Just s) = Resource.newSharedContext s hints (Just conf)
allowedHint :: WindowHint -> Bool
allowedHint (WindowHint'sRGBCapable _) = False
allowedHint (WindowHint'Visible _) = False
allowedHint (WindowHint'RedBits _) = False
allowedHint (WindowHint'GreenBits _) = False
allowedHint (WindowHint'BlueBits _) = False
allowedHint (WindowHint'AlphaBits _) = False
allowedHint (WindowHint'DepthBits _) = False
allowedHint (WindowHint'StencilBits _) = False
allowedHint (WindowHint'ContextVersionMajor _) = False
allowedHint (WindowHint'ContextVersionMinor _) = False
allowedHint (WindowHint'OpenGLForwardCompat _) = False
allowedHint (WindowHint'OpenGLProfile _) = False
allowedHint _ = True
begin :: C.MVar (C.Chan Message) -> IO ()
begin chReply = do
msgC <- C.newChan
C.putMVar chReply msgC
loop msgC
loop :: C.Chan Message -> IO ()
loop msgC = do
msg <- C.readChan msgC
case msg of
ReqShutDown reply -> GLFW.makeContextCurrent Nothing >> C.putMVar reply ()
ReqExecuteSync action reply -> action >>= C.putMVar reply >> loop msgC
ReqExecuteAsync action -> action >> loop msgC
contextDoSyncImpl :: Resource.Window -> C.Chan Message -> Bool -> IO a -> IO a
contextDoSyncImpl w msgC inwin action = do
reply <- C.newEmptyMVar
C.writeChan msgC $ ReqExecuteSync (do when inwin (GLFW.makeContextCurrent (Just w))
action)
reply
GLFW.pollEvents
C.takeMVar reply
contextDoAsyncImpl :: IORef Bool -> Resource.Window -> C.Chan Message -> Bool -> IO () -> IO ()
contextDoAsyncImpl alive w msgC inwin action =
C.writeChan msgC $ ReqExecuteAsync $ if inwin
then do
alive' <- readIORef alive
when alive' $ do
GLFW.makeContextCurrent (Just w)
action
else
action
mainthreadDoWhileContextUncurrent :: C.Chan Message -> Resource.Window -> IO a -> IO a
mainthreadDoWhileContextUncurrent msgC w mainAction = do
syncMainWait <- C.newEmptyMVar
syncRendWait <- C.newEmptyMVar
let m = do GLFW.makeContextCurrent Nothing
C.putMVar syncMainWait ()
C.takeMVar syncRendWait
GLFW.makeContextCurrent (Just w)
C.writeChan msgC $ ReqExecuteAsync m
C.takeMVar syncMainWait
ret <- mainAction
C.putMVar syncRendWait ()
return ret
contextDeleteImpl :: C.Chan Message -> IO ()
contextDeleteImpl msgC = do
syncMainWait <- C.newEmptyMVar
C.writeChan msgC $ ReqShutDown syncMainWait
C.takeMVar syncMainWait