diff --git a/GPipe-GLFW.cabal b/GPipe-GLFW.cabal --- a/GPipe-GLFW.cabal +++ b/GPipe-GLFW.cabal @@ -1,5 +1,5 @@ name: GPipe-GLFW -version: 1.1 +version: 1.2.1 cabal-version: >=1.10 build-type: Simple author: Patrick Redmond @@ -26,6 +26,8 @@ ghc-options: -Wall default-language: Haskell2010 exposed-modules: Graphics.GPipe.Context.GLFW + , Graphics.GPipe.Context.GLFW.Input + , Graphics.GPipe.Context.GLFW.Unsafe other-modules: Graphics.GPipe.Context.GLFW.Resource Graphics.GPipe.Context.GLFW.Util @@ -40,4 +42,4 @@ type: git location: git@github.com:plredmond/GPipe-GLFW.git subdir: GPipe-GLFW - tag: v1.1 + tag: v1.2.1 diff --git a/src/Graphics/GPipe/Context/GLFW.hs b/src/Graphics/GPipe/Context/GLFW.hs --- a/src/Graphics/GPipe/Context/GLFW.hs +++ b/src/Graphics/GPipe/Context/GLFW.hs @@ -1,22 +1,31 @@ -{-# LANGUAGE RankNTypes, GADTs #-} +{-# LANGUAGE RankNTypes, GADTs, DeriveDataTypeable #-} module Graphics.GPipe.Context.GLFW -( newContext, +( + -- * Creating contexts + newContext, + newContext', + -- * Data types + BadWindowHintsException(..), GLFWWindow(), - getCursorPos, getMouseButton, getKey, windowShouldClose, - MouseButtonState(..), MouseButton(..), KeyState(..), Key(..), + WindowConf(..), defaultWindowConf, + -- * Re-exported window actions + module Input ) where -import qualified Control.Concurrent as C 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 Graphics.UI.GLFW as GLFW (getCursorPos, getMouseButton, getKey, windowShouldClose, makeContextCurrent, destroyWindow, pollEvents) -import Control.Monad.IO.Class (MonadIO) -import Graphics.GPipe.Context (ContextFactory, ContextHandle(..),ContextT,withContextWindow) -import Graphics.UI.GLFW (MouseButtonState(..), MouseButton(..), KeyState(..), Key(..)) +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) +import Control.Monad (when, unless) +import Control.Exception (Exception, throwIO) +import Data.Typeable (Typeable) data Message where ReqShutDown :: C.MVar () -> Message @@ -26,27 +35,61 @@ ------------------------------------------------------------------------------ -- Top-level --- | An opaque value representing a GLFW OpenGL context window. -newtype GLFWWindow = GLFWWindow { unGLFWWindow :: Resource.Window } +-- | An exception which is thrown when you try to use 'WindowHint's that need to +-- be controlled by this library. Contains a list of the offending hints. +data BadWindowHintsException = BadWindowHintsException [WindowHint] + deriving (Show, Typeable) +instance Exception BadWindowHintsException + -- | The context factory which facilitates use of GLFW with GPipe. --- This has to be run from the main thread. +-- This has to be run from the main thread. newContext :: ContextFactory c ds GLFWWindow -newContext fmt = do +newContext = newContext' [] defaultWindowConf + +-- | The context factory which facilitates use of GLFW with GPipe. +-- This has to be run from the main thread. +-- +-- Accepts two extra parameters compared to 'newContext': a list of GLFW +-- 'WindowHint's and a 'WindowConf' which determines the width, height and title +-- of the window. +-- +-- Throws a 'BadWindowHintsException' if you use hints that need to be +-- controlled by this library. Disallowed hints are: +-- +-- > WindowHint'sRGBCapable +-- > WindowHint'Visible +-- > WindowHint'RedBits +-- > WindowHint'GreenBits +-- > WindowHint'BlueBits +-- > WindowHint'AlphaBits +-- > WindowHint'DepthBits +-- > WindowHint'StencilBits +-- > WindowHint'ContextVersionMajor +-- > WindowHint'ContextVersionMinor +-- > WindowHint'OpenGLForwardCompat +-- > WindowHint'OpenGLProfile +-- +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 msgC Nothing fmt + h <- createContext extraHints conf msgC Nothing fmt contextDoAsync h True (return ()) -- First action on render thread: Just make window current - return h + return h -createContext :: C.Chan Message -> Maybe Resource.Window -> ContextFactory c ds GLFWWindow -createContext msgC share fmt = do +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 -- This will always be used from render thread so no need to synchronize return ContextHandle - { newSharedContext = mainthreadDoWhileContextUncurrent msgC w . createContext msgC (Just w) -- Create context on this thread while parent is uncurrent, then make parent current + { newSharedContext = mainthreadDoWhileContextUncurrent msgC w . createContext extraHints conf msgC (Just w) -- Create context on this thread while parent is uncurrent, then make parent current , contextDoSync = contextDoSyncImpl w msgC , contextDoAsync = contextDoAsyncImpl alive w msgC , contextSwap = contextDoSyncImpl w msgC False $ Util.swapBuffers w -- explicitly do it on the render thread to sync properly, GLFW allows this @@ -58,11 +101,26 @@ , contextWindow = GLFWWindow w } where - hints = Format.toHints fmt + hints = Format.toHints fmt ++ extraHints makeContext :: Maybe Resource.Window -> IO Resource.Window - makeContext Nothing = Resource.newContext Nothing hints Nothing - makeContext (Just s) = Resource.newSharedContext s hints Nothing + makeContext Nothing = Resource.newContext Nothing hints (Just conf) + makeContext (Just s) = Resource.newSharedContext s hints (Just conf) +-- | Is the user allowed to use the given WindowHint? +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 ------------------------------------------------------------------------------ -- OpenGL Context thread @@ -93,32 +151,32 @@ C.writeChan msgC $ ReqExecuteSync (do when inwin (GLFW.makeContextCurrent (Just w)) action) reply - GLFW.pollEvents -- Ugly hack, but at least every swapContextBuffers will run this + GLFW.pollEvents -- Ugly hack, but at least every swapContextBuffers will run this C.takeMVar reply -- Dispatch asychronous concurrent IO to the OpenGL context thread contextDoAsyncImpl :: IORef Bool -> Resource.Window -> C.Chan Message -> Bool -> IO () -> IO () contextDoAsyncImpl alive w msgC inwin action = - C.writeChan msgC $ ReqExecuteAsync $ if inwin + C.writeChan msgC $ ReqExecuteAsync $ if inwin then do -- If needed to be run in this window, then only do it if window still exists - alive' <- readIORef alive - when alive' $ do + alive' <- readIORef alive + when alive' $ do GLFW.makeContextCurrent (Just w) action else action --- Do action while renderhtread is uncurrent +-- Do action while renderhtread is uncurrent 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.putMVar syncMainWait () C.takeMVar syncRendWait -- Stop other async code from making window current (e.g. finalizers) GLFW.makeContextCurrent (Just w) - - C.writeChan msgC $ ReqExecuteAsync m + + C.writeChan msgC $ ReqExecuteAsync m C.takeMVar syncMainWait -- Wait for render thread to make window uncurrent ret <- mainAction C.putMVar syncRendWait () -- Release render thread @@ -130,20 +188,5 @@ syncMainWait <- C.newEmptyMVar C.writeChan msgC $ ReqShutDown syncMainWait C.takeMVar syncMainWait - ------------------------------------------------------------------------------- --- Exposed window actions - -getCursorPos :: MonadIO m => ContextT GLFWWindow os f m (Double, Double) -getCursorPos = withContextWindow (GLFW.getCursorPos . unGLFWWindow) - -getMouseButton :: MonadIO m => MouseButton -> ContextT GLFWWindow os f m MouseButtonState -getMouseButton mb = withContextWindow (\(GLFWWindow w) -> GLFW.getMouseButton w mb) - -getKey :: MonadIO m => Key -> ContextT GLFWWindow os f m KeyState -getKey k = withContextWindow (\(GLFWWindow w) -> GLFW.getKey w k) - -windowShouldClose :: MonadIO m => ContextT GLFWWindow os f m Bool -windowShouldClose = withContextWindow (GLFW.windowShouldClose . unGLFWWindow) -- eof diff --git a/src/Graphics/GPipe/Context/GLFW/Input.hs b/src/Graphics/GPipe/Context/GLFW/Input.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GPipe/Context/GLFW/Input.hs @@ -0,0 +1,37 @@ +-- | Window actions, mostly corresponding to user input. Analogous to those from +-- 'Graphics.UI.GLFW', but in the GPipe 'ContextT' monad. +module Graphics.GPipe.Context.GLFW.Input +( + -- * Exposed actions + getCursorPos, + getMouseButton, + getKey, + windowShouldClose, + -- * Re-exported from GLFW + MouseButtonState(..), MouseButton(..), KeyState(..), Key(..) +) where + +import Graphics.GPipe.Context.GLFW.Unsafe (GLFWWindow(..)) + +import Control.Monad.IO.Class (MonadIO) +import Graphics.GPipe.Context (ContextT, withContextWindow) +import qualified Graphics.UI.GLFW as GLFW (getCursorPos, getMouseButton, getKey, windowShouldClose) +import Graphics.UI.GLFW (MouseButtonState(..), MouseButton(..), KeyState(..), Key(..)) + +-- | Gets the current cursor position, in pixels relative to the top-left corner +-- of the window. +getCursorPos :: MonadIO m => ContextT GLFWWindow os f m (Double, Double) +getCursorPos = withContextWindow (GLFW.getCursorPos . getGLFWWindow) + +-- | Gets the state of the specified 'MouseButton'. +getMouseButton :: MonadIO m => MouseButton -> ContextT GLFWWindow os f m MouseButtonState +getMouseButton mb = withContextWindow (\(GLFWWindow w) -> GLFW.getMouseButton w mb) + +-- | Gets the state of the specified 'Key'. +getKey :: MonadIO m => Key -> ContextT GLFWWindow os f m KeyState +getKey k = withContextWindow (\(GLFWWindow w) -> GLFW.getKey w k) + +-- | Returns 'True' if the window should close (e.g. because the user pressed +-- the \'x\' button). +windowShouldClose :: MonadIO m => ContextT GLFWWindow os f m Bool +windowShouldClose = withContextWindow (GLFW.windowShouldClose . getGLFWWindow) diff --git a/src/Graphics/GPipe/Context/GLFW/Resource.hs b/src/Graphics/GPipe/Context/GLFW/Resource.hs --- a/src/Graphics/GPipe/Context/GLFW/Resource.hs +++ b/src/Graphics/GPipe/Context/GLFW/Resource.hs @@ -1,9 +1,12 @@ {-# LANGUAGE PackageImports #-} --- Bracketed GLFW resource initializers +{-# LANGUAGE CPP #-} +-- | Bracketed GLFW resource initializers. module Graphics.GPipe.Context.GLFW.Resource ( newContext , newSharedContext -, WindowConf +, WindowConf(..) +, GLFWWindow(..) +, defaultWindowConf , Window , ErrorCallback ) where @@ -13,11 +16,19 @@ import qualified Data.Maybe as M import qualified Text.Printf as P +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif ------------------------------------------------------------------------------ -- Types & Constants +-- | A value representing a GLFW OpenGL context window. +newtype GLFWWindow = GLFWWindow + { + getGLFWWindow :: GLFW.Window + } + -- reexports type Window = GLFW.Window type ErrorCallback = GLFW.ErrorCallback @@ -26,13 +37,17 @@ defaultOnError :: ErrorCallback defaultOnError err msg = fail $ P.printf "%s: %s" (show err) msg --- initial window size & title suggestions +-- | Initial window size and title suggestions for GLFW. The window will usually +-- be set to the given size with the given title, unless the window manager +-- overrides this. data WindowConf = WindowConf { width :: Int , height :: Int , title :: String } +-- | A set of sensible defaults for the 'WindowConf'. Used by +-- 'Graphics.GPipe.Context.GLFW.newContext'. defaultWindowConf :: WindowConf defaultWindowConf = WindowConf 1024 768 "GLFW Window" diff --git a/src/Graphics/GPipe/Context/GLFW/Unsafe.hs b/src/Graphics/GPipe/Context/GLFW/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GPipe/Context/GLFW/Unsafe.hs @@ -0,0 +1,20 @@ +-- | Exposes some underlying implementation details which can be used to +-- gain access to 'Graphics.UI.GLFW' functionality that isn't exposed by this +-- library otherwise, but which can be dangerous if used incorrectly. +-- +-- The underlying 'Graphics.UI.GLFW.Window' object can be retrieved from a +-- 'GLFWWindow' using 'getGLFWWindow'.It can be used inside a +-- 'Graphics.GPipe.Context.ContextT' as follows: +-- +-- > withContextWindow (\win -> doSomething (getGLFWWindow win)) +-- +-- Bear in mind that it is possible to do bad things with this. For example, using +-- 'GLFW.makeContextCurrent' could cause GPipe to lose control of the window, +-- and 'GLFW.destroyWindow' is bad for obvious reasons. +-- +-- See 'Graphics.GPipe.Context.GLFW.Input' for concrete examples. +module Graphics.GPipe.Context.GLFW.Unsafe + ( GLFWWindow(..) ) + where + +import Graphics.GPipe.Context.GLFW.Resource (GLFWWindow(..))