packages feed

GPipe-GLFW (empty) → 1.0

raw patch · 7 files changed

+340/−0 lines, 7 filesdep +GLFW-bdep +GPipedep +basesetup-changed

Dependencies added: GLFW-b, GPipe, base, transformers

Files

+ GPipe-GLFW.cabal view
@@ -0,0 +1,43 @@+name:                GPipe-GLFW+version:             1.0+cabal-version:       >=1.10+build-type:          Simple+author:              Patrick Redmond+license:        MIT+license-file:   LICENSE+copyright:      Patrick Redmond+category:       Graphics+stability:      Experimental+synopsis:       GLFW OpenGL context creation for GPipe+homepage:       https://github.com/plredmond/GPipe-GLFW+description:+                A utility library to enable the use of GLFW as the OpenGL window and context handler for GPipe.+                GPipe is a typesafe functional API based on the conceptual model of OpenGL, but without the imperative state machine.+                See the GPipe package and resources for more information.+maintainer:     Patrick Redmond++library+  hs-source-dirs:      src+  build-depends:+                       base >=4.7 && <4.9,+                       transformers >= 0.3 && < 0.5,+                       GLFW-b >=1.4 && <1.5,+                       GPipe >=2.0 && <2.1+  ghc-options:         -Wall+  default-language:    Haskell2010+  exposed-modules:     Graphics.GPipe.Context.GLFW+  other-modules:+                       Graphics.GPipe.Context.GLFW.Resource+                       Graphics.GPipe.Context.GLFW.Util+                       Graphics.GPipe.Context.GLFW.Format++source-repository head+  type:     git+  location: git@github.com:plredmond/GPipe-GLFW.git+  subdir:   GPipe-GLFW++source-repository this+  type:     git+  location: git@github.com:plredmond/GPipe-GLFW.git+  subdir:   GPipe-GLFW+  tag:      v1.0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 PLR++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Graphics/GPipe/Context/GLFW.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE RankNTypes, GADTs #-}+module Graphics.GPipe.Context.GLFW+( newContext,+  GLFWWindow(),+  getCursorPos, getMouseButton, getKey, windowShouldClose,+  MouseButtonState(..), MouseButton(..), KeyState(..), Key(..),+) where++import qualified Control.Concurrent as C+import qualified Control.Monad as M+import qualified Graphics.GPipe.Context.GLFW.Format as Format+import qualified Graphics.GPipe.Context.GLFW.Resource as Resource+import qualified Graphics.GPipe.Context.GLFW.Util as Util+import qualified Graphics.UI.GLFW as GLFW (getCursorPos, getMouseButton, getKey, windowShouldClose, makeContextCurrent, destroyWindow)++import Control.Monad.IO.Class (MonadIO)+import Data.Maybe (isNothing)+import Graphics.GPipe.Context (ContextFactory, ContextHandle(..),ContextT,withContextWindow)+import Graphics.GPipe.Format (ContextFormat)+import Graphics.UI.GLFW (MouseButtonState(..), MouseButton(..), KeyState(..), Key(..))++type Message = Maybe Request++data Request where+    ReqExecute :: forall a. IO a -> Maybe (C.MVar a) -> Request++------------------------------------------------------------------------------+-- Top-level++-- | An opaque value representing a GLFW OpenGL context window.+newtype GLFWWindow = GLFWWindow { unGLFWWindow :: Resource.Window }++-- | The context factory which facilitates use of GLFW with GPipe.+newContext :: ContextFactory c ds GLFWWindow+newContext fmt = do+    chReply <- C.newEmptyMVar+    _ <- C.forkOS $ begin chReply fmt+    C.takeMVar chReply++createContext :: C.Chan Message -> Maybe Resource.Window -> ContextFactory c ds GLFWWindow+createContext msgC share fmt = do+    w <- makeContext share+    return ContextHandle+        { newSharedContext = contextDoSyncImpl w msgC . createContext msgC (Just w)+        , contextDoSync = contextDoSyncImpl w msgC+        , contextDoAsync = contextDoAsyncImpl w msgC+        , contextSwap = Util.swapBuffers w -- this thread only+        , contextFrameBufferSize = Util.getFramebufferSize w -- this thread only+        , contextDelete = do+            contextDoSyncImpl w msgC (GLFW.destroyWindow w)+            -- Shut down thread when outermost shared context is destroyed+            M.when (isNothing share) $ contextDeleteImpl msgC+        , contextWindow = GLFWWindow w+        }+    where+        hints = Format.toHints fmt+        makeContext :: Maybe Resource.Window -> IO Resource.Window+        makeContext Nothing = Resource.newContext Nothing hints Nothing+        makeContext (Just s) = Resource.newSharedContext s hints Nothing++------------------------------------------------------------------------------+-- OpenGL Context thread++-- Create and pass back a ContextHandle. Enter loop.+begin :: C.MVar (ContextHandle GLFWWindow) -> ContextFormat c ds -> IO ()+begin chReply fmt = do+    msgC <- C.newChan+    handle <- createContext msgC Nothing fmt+    C.putMVar chReply handle+    loop msgC++-- Handle messages until a stop message is received.+loop :: C.Chan Message -> IO ()+loop msgC = do+    msg <- C.readChan msgC+    case msg of+        Nothing -> return ()+        Just req -> doRequest req >> loop msgC++-- Do what the a request asks.+doRequest :: Request -> IO ()+doRequest (ReqExecute action Nothing) = M.void action+doRequest (ReqExecute action (Just reply)) = action >>= C.putMVar reply++------------------------------------------------------------------------------+-- Application rpc calls++-- Await sychronous concurrent IO from the OpenGL context thread+contextDoSyncImpl :: Resource.Window -> C.Chan Message -> IO a -> IO a+contextDoSyncImpl w msgC action = do+    reply <- C.newEmptyMVar+    C.writeChan msgC . Just $ ReqExecute (GLFW.makeContextCurrent (Just w) >> action) (Just reply)+    C.takeMVar reply++-- Dispatch asychronous concurrent IO to the OpenGL context thread+contextDoAsyncImpl :: Resource.Window -> C.Chan Message -> IO () -> IO ()+contextDoAsyncImpl w msgC action =+    C.writeChan msgC . Just $ ReqExecute (GLFW.makeContextCurrent (Just w) >> action) Nothing++-- Request that the OpenGL context thread shut down+contextDeleteImpl :: C.Chan Message -> IO ()+contextDeleteImpl msgC =+    C.writeChan msgC Nothing++------------------------------------------------------------------------------+-- 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
+ src/Graphics/GPipe/Context/GLFW/Format.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE PackageImports, GADTs #-}+-- Gpipe format to GLFW window-hint conversion+module Graphics.GPipe.Context.GLFW.Format+( toHints+) where++import qualified "GLFW-b" Graphics.UI.GLFW as GLFW+import qualified Graphics.GPipe.Format as F++------------------------------------------------------------------------------+-- Top-level++toHints :: F.ContextFormat c ds -> [GLFW.WindowHint]+toHints fmt =+    [ GLFW.WindowHint'sRGBCapable sRGB+    , GLFW.WindowHint'Visible visible+    , GLFW.WindowHint'RedBits red+    , GLFW.WindowHint'GreenBits green+    , GLFW.WindowHint'BlueBits blue+    , GLFW.WindowHint'AlphaBits alpha+    , GLFW.WindowHint'DepthBits depth+    , GLFW.WindowHint'StencilBits stencil++    , GLFW.WindowHint'ContextVersionMajor 3+    , GLFW.WindowHint'ContextVersionMinor 3+    , GLFW.WindowHint'OpenGLForwardCompat True+    , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core+    ]+    where+        ((red, green, blue, alpha, sRGB), depth, stencil) = F.contextBits fmt+        visible = case fmt of+            F.ContextFormatNone -> False+            _ -> True++-- eof
+ src/Graphics/GPipe/Context/GLFW/Resource.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE PackageImports #-}+-- Bracketed GLFW resource initializers+module Graphics.GPipe.Context.GLFW.Resource+( newContext+, newSharedContext+, WindowConf+, Window+, ErrorCallback+) where++import qualified "GLFW-b" Graphics.UI.GLFW as GLFW+import qualified Control.Exception as Exc+import qualified Data.Maybe as M+import qualified Text.Printf as P++import Control.Applicative ((<$>))++------------------------------------------------------------------------------+-- Types & Constants++-- reexports+type Window = GLFW.Window+type ErrorCallback = GLFW.ErrorCallback++-- a default error callback which ragequits+defaultOnError :: ErrorCallback+defaultOnError err msg = fail $ P.printf "%s: %s" (show err) msg++-- initial window size & title suggestions+data WindowConf = WindowConf+    { width :: Int+    , height :: Int+    , title :: String+    }++defaultWindowConf :: WindowConf+defaultWindowConf = WindowConf 1024 768 "GLFW Window"++------------------------------------------------------------------------------+-- Code++-- set and unset the GLFW error callback, using a default if none is provided+withErrorCallback :: Maybe ErrorCallback -> IO a -> IO a+withErrorCallback customOnError =+    Exc.bracket_+        (GLFW.setErrorCallback $ Just onError)+        (GLFW.setErrorCallback Nothing)+    where+        onError :: ErrorCallback+        onError = M.fromMaybe defaultOnError customOnError++-- init and terminate GLFW+withGLFW :: IO a -> IO a+withGLFW =+    Exc.bracket_+        GLFW.init+        $ return () -- GLFW.terminate+        -- to clean up we should call GLFW.terminate, but it currently breaks+        -- see issue https://github.com/bsl/GLFW-b/issues/54++-- reset window hints and apply the given list, afterward reset window hints+withHints :: [GLFW.WindowHint] -> IO a -> IO a+withHints hints =+    Exc.bracket_+        (GLFW.defaultWindowHints >> mapM_ GLFW.windowHint hints)+        GLFW.defaultWindowHints++-- create a window, as the current context, using any monitor+-- if given a `Window`, create the new window's context from that+newWindow :: Maybe Window -> Maybe WindowConf -> IO Window+newWindow share customWindowConf =+    M.fromMaybe noWindow <$> createWindowHuh+    where+        WindowConf {width=w, height=h, title=t} = M.fromMaybe defaultWindowConf customWindowConf+        createWindowHuh :: IO (Maybe Window)+        createWindowHuh = do+            GLFW.makeContextCurrent Nothing+            win <- GLFW.createWindow w h t Nothing share+            GLFW.makeContextCurrent win+            return win+        noWindow :: Window+        noWindow = error "Couldn't create a window"++------------------------------------------------------------------------------+-- Top-level++-- establish a *new* opengl context+newContext :: Maybe ErrorCallback -> [GLFW.WindowHint] -> Maybe WindowConf -> IO Window+newContext ec hints wc+    = withErrorCallback ec+    . withGLFW+    . withHints hints+    $ newWindow Nothing wc++-- establish a *shared* opengl context+newSharedContext :: Window -> [GLFW.WindowHint] -> Maybe WindowConf -> IO Window+newSharedContext ctx hints wc+    = withHints hints+    $ newWindow (Just ctx) wc++-- eof
+ src/Graphics/GPipe/Context/GLFW/Util.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE PackageImports #-}+-- Pass-through functions+module Graphics.GPipe.Context.GLFW.Util+( swapBuffers+, getFramebufferSize+) where++import qualified "GLFW-b" Graphics.UI.GLFW as GLFW++------------------------------------------------------------------------------+-- Util++swapBuffers :: GLFW.Window -> IO ()+swapBuffers w = GLFW.makeContextCurrent (Just w) >> GLFW.swapBuffers w >> GLFW.pollEvents++getFramebufferSize :: GLFW.Window -> IO (Int, Int)+getFramebufferSize w = GLFW.makeContextCurrent (Just w) >> GLFW.getFramebufferSize w++-- eof