GPipe-GLFW 1.1 → 1.2.1

raw patch · 5 files changed

+167/−50 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• GPipe-GLFW.cabal +4/−2
• src/Graphics/GPipe/Context/GLFW.hs +88/−45
• src/Graphics/GPipe/Context/GLFW/Input.hs +37/−0
• src/Graphics/GPipe/Context/GLFW/Resource.hs +18/−3
• src/Graphics/GPipe/Context/GLFW/Unsafe.hs +20/−0

@@ -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

@@ -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

@@ -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)

@@ -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" 

@@ -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(..))