GPipe-GLFW 1.3.0 → 1.4.0

raw patch · 17 files changed

+859/−668 lines, 17 filesdep +asyncdep +containersdep +stmdep −GPipe-GLFWdep −exception-transformersdep −transformersdep ~GPipedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: async, containers, stm

Dependencies removed: GPipe-GLFW, exception-transformers, transformers

Dependency ranges changed: GPipe, base

API changes (from Hackage documentation)

Files

• GPipe-GLFW.cabal +19/−29
• src/Graphics/GPipe/Context/GLFW.hs +39/−187
• src/Graphics/GPipe/Context/GLFW/Calls.hs +222/−0
• src/Graphics/GPipe/Context/GLFW/Format.hs +45/−24
• src/Graphics/GPipe/Context/GLFW/Handler.hs +329/−0
• src/Graphics/GPipe/Context/GLFW/Input.hs +60/−85
• src/Graphics/GPipe/Context/GLFW/RPC.hs +71/−0
• src/Graphics/GPipe/Context/GLFW/Resource.hs +21/−113
• src/Graphics/GPipe/Context/GLFW/Unsafe.hs +0/−20
• src/Graphics/GPipe/Context/GLFW/Util.hs +0/−19
• src/Graphics/GPipe/Context/GLFW/Wrapped.hs +19/−0
• src/Graphics/GPipe/Context/GLFW/Wrappers.hs +34/−0
• test/Spec.hs +0/−12
• test/Test/Basic.hs +0/−17
• test/Test/Common.hs +0/−128
• test/Test/Multi.hs +0/−16
• test/Test/Split.hs +0/−18

@@ -1,8 +1,8 @@-name:                GPipe-GLFW-version:             1.3.0-cabal-version:       >=1.10-build-type:          Simple-author:              Patrick Redmond+name:           GPipe-GLFW+version:        1.4.0+cabal-version:  >=1.10+build-type:     Simple+author:         Patrick Redmond license:        MIT license-file:   LICENSE copyright:      Patrick Redmond@@ -19,33 +19,23 @@  library   hs-source-dirs:      src-  build-depends:       base         >= 4.7 && <4.10-                     , transformers >= 0.3 && <0.6-                     , GLFW-b       >= 1.4 && <1.5-                     , GPipe        >= 2.1 && <2.2-  ghc-options:         -Wall+  build-depends:       base                   >= 4.7 && <4.10+                     , stm                    >= 2.4 && <2.5+                     , containers             >= 0.5 && <0.6+                     , async                  >= 2.1 && <2.3+                     , GLFW-b                 >= 1.4 && <1.5+                     , GPipe                  >= 2.2 && <2.3+  ghc-options:         -Wall -Wno-orphans   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+                       Graphics.GPipe.Context.GLFW.Wrapped+  other-modules:       Graphics.GPipe.Context.GLFW.Calls+                       Graphics.GPipe.Context.GLFW.Resource+                       Graphics.GPipe.Context.GLFW.Wrappers                        Graphics.GPipe.Context.GLFW.Format--executable gpipe-glfw-smoketests-  hs-source-dirs:      test-  main-is:             Spec.hs-  build-depends:       base-                     , GPipe-                     , GPipe-GLFW-                     , transformers-                     , exception-transformers-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N-  default-language:    Haskell2010-  other-modules:       Test.Common-                       Test.Basic-                       Test.Split-                       Test.Multi+                       Graphics.GPipe.Context.GLFW.Handler+                       Graphics.GPipe.Context.GLFW.RPC  source-repository head   type:     git@@ -56,4 +46,4 @@   type:     git   location: https://github.com/plredmond/GPipe-GLFW.git   subdir:   GPipe-GLFW-  tag:      v1.3.0+  tag:      v1.4.0

@@ -1,192 +1,44 @@-{-# LANGUAGE RankNTypes, GADTs, DeriveDataTypeable #-}-module Graphics.GPipe.Context.GLFW-(-  -- * Creating contexts-  newContext,-  newContext',-  -- * Data types-  BadWindowHintsException(..),-  GLFWWindow(),-  WindowConf(..), defaultWindowConf,-  -- * Re-exported window actions-  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----------------------------------------------------------------------------------- Top-level---- | 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.-newContext :: ContextFactory c ds GLFWWindow-newContext = newContext' [] defaultWindowConf---- | The context factory which facilitates use of GLFW with GPipe.--- This has to be run from the main thread.+-- | Non interactive applications only need to pass configuration defined here+-- into GPipe's 'runContextT' and 'newWindow'. ----- 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.+-- For user input, see "Graphics.GPipe.Context.GLFW.Input". All other GLFW+-- functionality is being incrementally exposed in+-- "Graphics.GPipe.Context.GLFW.Wrapped".+module Graphics.GPipe.Context.GLFW (+-- * GPipe context handler for GLFW+Handle(),+GLFWWindow(),+-- ** Configuration+-- *** Defaults+defaultHandleConfig,+defaultWindowConfig,+-- *** Details+ContextHandlerParameters(HandleConfig, configErrorCallback, configEventPolicy),+-- | Configuration for the GLFW handle. ----- Throws a 'BadWindowHintsException' if you use hints that need to be--- controlled by this library. Disallowed hints are:+-- [@'HandleConfig'@] Constructor ----- > WindowHint'sRGBCapable--- > WindowHint'Visible--- > WindowHint'RedBits--- > WindowHint'GreenBits--- > WindowHint'BlueBits--- > WindowHint'AlphaBits--- > WindowHint'DepthBits--- > WindowHint'StencilBits--- > WindowHint'ContextVersionMajor--- > WindowHint'ContextVersionMinor--- > WindowHint'OpenGLForwardCompat--- > WindowHint'OpenGLProfile+-- [@'configErrorCallback' :: ErrorCallback@] Specify a callback to handle errors captured by GLFW. ---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 ()) -- First action on render thread: Just make window current-    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 -- This will always be used from render thread so no need to synchronize-    return ContextHandle-        { 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-        , contextFrameBufferSize = Util.getFramebufferSize w -- Runs on mainthread-        , contextDelete = case share of-            Nothing -> do contextDeleteImpl msgC -- This return when render thread is uncurrent and is shutting down (cannot serve any finalizers)-                          GLFW.destroyWindow w-            Just parentW  -> mainthreadDoWhileContextUncurrent msgC parentW (writeIORef alive False >> GLFW.destroyWindow w) -- Shared contexts still alive, delete while uncurrent, then make parent win current-        , 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)---- | 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---- Create and pass back a channel. Enter loop.-begin :: C.MVar (C.Chan Message) ->  IO ()-begin chReply = do-    msgC <- C.newChan-    C.putMVar chReply msgC-    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-        ReqShutDown reply -> GLFW.makeContextCurrent Nothing >> C.putMVar reply ()-        ReqExecuteSync action reply -> action >>= C.putMVar reply >> loop msgC-        ReqExecuteAsync action -> action >> loop msgC----------------------------------------------------------------------------------- Application rpc calls---- Await sychronous concurrent IO from the OpenGL context thread-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 -- 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-                                            then do -- If needed to be run in this window, then only do it if window still exists-                                                alive' <- readIORef alive-                                                when alive' $ do-                                                        GLFW.makeContextCurrent (Just w)-                                                        action-                                            else-                                                action---- 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.takeMVar syncRendWait -- Stop other async code from making window current (e.g. finalizers)-               GLFW.makeContextCurrent (Just w)--    C.writeChan msgC $ ReqExecuteAsync m-    C.takeMVar syncMainWait -- Wait for render thread to make window uncurrent-    ret <- mainAction-    C.putMVar syncRendWait () -- Release render thread-    return ret---- Request that the OpenGL context thread shut down-contextDeleteImpl :: C.Chan Message -> IO ()-contextDeleteImpl msgC = do-    syncMainWait <- C.newEmptyMVar-    C.writeChan msgC $ ReqShutDown syncMainWait-    C.takeMVar syncMainWait+-- [@'configEventPolicy' :: Maybe 'EventPolicy'@] Specify the 'EventPolicy' to use for automatic GLFW event processing. If 'Nothing' then automatic event processing is disabled and you'll need to call 'mainloop' or 'mainstep' somewhere.+WindowConfig(..),+EventPolicy(..),+-- ** Exceptions+InitException(..),+CreateWindowException(..),+UnsafeWindowHintsException(..),+-- ** Mainthread hooks+mainloop,+mainstep,+-- ** Reexports+module Graphics.GPipe.Context.GLFW.Input,+module Graphics.GPipe.Context.GLFW.Wrapped+) where --- eof+-- internal+import Graphics.GPipe.Context.GLFW.Format+import Graphics.GPipe.Context.GLFW.Resource+import Graphics.GPipe.Context.GLFW.Handler+-- reexports+import Graphics.GPipe.Context.GLFW.Input+import Graphics.GPipe.Context.GLFW.Wrapped

@@ -0,0 +1,222 @@+-- | Internal module wrapping calls to "Graphics.UI.GLFW"+--+-- The bulletpoints on each function are copied from the GLFW documentation.+module Graphics.GPipe.Context.GLFW.Calls where++-- stdlib+import Control.Monad (when)+import qualified Text.Printf as Text+import qualified Control.Concurrent as Conc+-- thirdparty+import qualified Graphics.UI.GLFW as GLFW++-- TODO: change from using explicit OnMain functions to passing a handle which implements the appropriate class (effect or fetch result)+-- TODO: maybe an OnMain monad would be good to reduce the number of RPCS? Not really necessary, since they can already be easily sequenced with IO++-- |+-- * 2x This function may be called from any thread.+-- * Reading and writing of the internal timer offset is not atomic, so it needs to be externally synchronized with calls to glfwSetTime.+debug :: String -> IO ()+debug msg = do+    t <- GLFW.getTime+    tid <- Conc.myThreadId+    c <- GLFW.getCurrentContext+    Text.printf "[%03.3fs, %s has %s]: %s\n" (maybe (0/0) id t) (show tid) (show c) msg++type OnMain a = IO a -> IO a+type EffectMain = IO () -> IO ()++-- |+-- * This function must only be called from the main thread.+init :: OnMain Bool -> IO Bool+init onMain = onMain GLFW.init++-- |+-- * This function may be called before glfwInit.+-- * The contexts of any remaining windows must not be current on any other thread when this function is called.+-- * ~~This function must not be called from a callback.~~+-- * This function must only be called from the main thread.+terminate :: EffectMain -> IO ()+terminate onMain = onMain GLFW.terminate++-- |+-- * This function may be called before glfwInit.+-- * This function must only be called from the main thread.+setErrorCallback :: EffectMain -> Maybe GLFW.ErrorCallback -> IO ()+setErrorCallback onMain callbackHuh = onMain $ GLFW.setErrorCallback callbackHuh++-- | +-- * There are many caveats: http://www.glfw.org/docs/latest/group__window.html#ga5c336fddf2cbb5b92f65f10fb6043344+-- * ~~This function must not be called from a callback.~~+-- * This function must only be called from the main thread.+createWindow :: OnMain (Maybe GLFW.Window) -> Int -> Int -> String -> Maybe GLFW.Monitor -> [GLFW.WindowHint] -> Maybe GLFW.Window -> IO (Maybe GLFW.Window)+createWindow onMain width height title monitor hints parent = onMain $ do+    GLFW.defaultWindowHints -- This function must only be called from the main thread.+    mapM_ GLFW.windowHint hints -- This function must only be called from the main thread.+    GLFW.createWindow width height title monitor parent++-- |+-- * If the context of the specified window is current on the main thread, it is detached before being destroyed.+-- * The context of the specified window must not be current on any other thread when this function is called.+-- * ~~This function must not be called from a callback.~~+-- * This function must only be called from the main thread.+--+-- Seems like it's ok to delete any of the shared contexts any time, per:+-- https://khronos.org/registry/OpenGL/specs/gl/glspec45.core.pdf (Section 5.1.1)+destroyWindow :: EffectMain -> GLFW.Window -> IO ()+destroyWindow onMain window = onMain $ GLFW.destroyWindow window++-- |+-- * 2x This function must only be called from the main thread.+windowHints :: EffectMain -> [GLFW.WindowHint] -> IO ()+windowHints onMain hints = onMain $ GLFW.defaultWindowHints >> mapM_ GLFW.windowHint hints++-- |+-- * This function may be called from any thread.+makeContextCurrent :: String -> Maybe GLFW.Window -> IO ()+makeContextCurrent reason windowHuh = do+    ccHuh <- GLFW.getCurrentContext+    when (ccHuh /= windowHuh) $ do+        debug $ Text.printf "attaching %s, reason: %s" (show windowHuh) reason+        GLFW.makeContextCurrent windowHuh++-- | +-- * A context must be current on the calling thread. Calling this function without a current context will cause a GLFW_NO_CURRENT_CONTEXT error.+-- * This function is not called during context creation, leaving the swap interval set to whatever is the default on that platform. This is done because some swap interval extensions used by GLFW do not allow the swap interval to be reset to zero once it has been set to a non-zero value.+-- * This function may be called from any thread.+swapInterval :: Int -> IO ()+swapInterval interval = GLFW.swapInterval interval++-- |+-- * EGL: The context of the specified window must be current on the calling thread.+-- * This function may be called from any thread.+swapBuffers :: GLFW.Window -> IO ()+swapBuffers window = GLFW.swapBuffers window++-- | This function puts the calling thread to sleep until at least one event is available in the event queue.+-- * ~~This function must not be called from a callback.~~+-- * This function must only be called from the main thread.+waitEvents :: EffectMain -> IO ()+waitEvents onMain = onMain GLFW.waitEvents++-- | This function processes only those events that are already in the event queue and then returns immediately.+-- * ~~This function must not be called from a callback.~~+-- * This function must only be called from the main thread.+pollEvents :: EffectMain -> IO ()+pollEvents onMain = onMain GLFW.pollEvents++-- | This function posts an empty event from the current thread to the event queue, causing glfwWaitEvents or glfwWaitEventsTimeout to return.+-- * This function may be called from any thread.+postEmptyEvent :: IO ()+postEmptyEvent = GLFW.postEmptyEvent++-- |+-- * This function may be called from any thread. Access is not synchronized.+windowShouldClose :: GLFW.Window -> IO Bool+windowShouldClose window = GLFW.windowShouldClose window++-- |+-- * This function may be called from any thread. Access is not synchronized.+setWindowShouldClose :: GLFW.Window -> Bool -> IO ()+setWindowShouldClose window bool = GLFW.setWindowShouldClose window bool++-- |+-- * This function must only be called from the main thread.+getFramebufferSize :: OnMain (Int, Int) -> GLFW.Window -> IO (Int, Int)+getFramebufferSize onMain window = onMain $ GLFW.getFramebufferSize window++-- |+-- * This function must only be called from the main thread.+setKeyCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.KeyCallback -> IO ()+setKeyCallback onMain window cb = onMain $ GLFW.setKeyCallback window cb++-- |+-- * Do not use this function to implement text input.+-- * This function must only be called from the main thread.+getKey :: OnMain GLFW.KeyState -> GLFW.Window -> GLFW.Key -> IO GLFW.KeyState+getKey onMain window key = onMain $ GLFW.getKey window key++-- | Implemented with glfwSetInputMode+-- * This function must only be called from the main thread.+setStickyKeysInputMode :: EffectMain -> GLFW.Window -> GLFW.StickyKeysInputMode -> IO ()+setStickyKeysInputMode onMain window mode = onMain $ GLFW.setStickyKeysInputMode window mode++-- | Implemented with glfwGetInputMode+-- * This function must only be called from the main thread.+getStickyKeysInputMode :: OnMain GLFW.StickyKeysInputMode -> GLFW.Window -> IO GLFW.StickyKeysInputMode+getStickyKeysInputMode onMain window = onMain $ GLFW.getStickyKeysInputMode window++-- |+-- * This function must only be called from the main thread.+setCharCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.CharCallback -> IO ()+setCharCallback onMain window cb = onMain $ GLFW.setCharCallback window cb++-- |+-- * This function must only be called from the main thread.+setCursorPosCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.CursorPosCallback -> IO ()+setCursorPosCallback onMain window cb = onMain $ GLFW.setCursorPosCallback window cb++-- |+-- * This function must only be called from the main thread.+getCursorPos :: OnMain (Double, Double) -> GLFW.Window -> IO (Double, Double)+getCursorPos onMain window = onMain $ GLFW.getCursorPos window++-- | Implemented with glfwSetInputMode+-- * This function must only be called from the main thread.+setCursorInputMode :: EffectMain -> GLFW.Window -> GLFW.CursorInputMode -> IO ()+setCursorInputMode onMain window mode = onMain $ GLFW.setCursorInputMode window mode++-- | Implemented with glfwGetInputMode+-- * This function must only be called from the main thread.+getCursorInputMode :: OnMain GLFW.CursorInputMode -> GLFW.Window -> IO GLFW.CursorInputMode+getCursorInputMode onMain window = onMain $ GLFW.getCursorInputMode window++-- |+-- * This function must only be called from the main thread.+setCursor :: EffectMain -> GLFW.Window -> GLFW.Cursor -> IO ()+setCursor onMain window cursor = onMain $ GLFW.setCursor window cursor++-- |+-- * This function must only be called from the main thread.+setCursorEnterCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.CursorEnterCallback -> IO ()+setCursorEnterCallback onMain window cb = onMain $ GLFW.setCursorEnterCallback window cb++-- |+-- * This function must only be called from the main thread.+setMouseButtonCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.MouseButtonCallback -> IO ()+setMouseButtonCallback onMain window cb = onMain $ GLFW.setMouseButtonCallback window cb++-- |+-- * This function must only be called from the main thread.+getMouseButton :: OnMain GLFW.MouseButtonState -> GLFW.Window -> GLFW.MouseButton -> IO GLFW.MouseButtonState+getMouseButton onMain window button = onMain $ GLFW.getMouseButton window button++-- | Implemented with glfwSetInputMode+-- * This function must only be called from the main thread.+setStickyMouseButtonsInputMode :: EffectMain -> GLFW.Window -> GLFW.StickyMouseButtonsInputMode -> IO ()+setStickyMouseButtonsInputMode onMain window mode = onMain $ GLFW.setStickyMouseButtonsInputMode window mode++-- | Implemented with glfwGetInputMode+-- * This function must only be called from the main thread.+getStickyMouseButtonsInputMode :: OnMain GLFW.StickyMouseButtonsInputMode -> GLFW.Window -> IO GLFW.StickyMouseButtonsInputMode+getStickyMouseButtonsInputMode onMain window = onMain $ GLFW.getStickyMouseButtonsInputMode window++-- |+-- * This function must only be called from the main thread.+setScrollCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.ScrollCallback -> IO ()+setScrollCallback onMain window cb = onMain $ GLFW.setScrollCallback window cb++-- |+-- * This function must only be called from the main thread.+getClipboardString :: OnMain (Maybe String) -> GLFW.Window -> IO (Maybe String)+getClipboardString onMain window = onMain $ GLFW.getClipboardString window++-- |+-- * This function must only be called from the main thread.+setClipboardString :: EffectMain -> GLFW.Window -> String -> IO ()+setClipboardString onMain window s = onMain $ GLFW.setClipboardString window s++-- |+-- * This function must only be called from the main thread.+setDropCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.DropCallback -> IO ()+setDropCallback onMain window cb = onMain $ GLFW.setDropCallback window cb

@@ -1,35 +1,56 @@-{-# LANGUAGE PackageImports, GADTs #-}--- Gpipe format to GLFW window-hint conversion-module Graphics.GPipe.Context.GLFW.Format-( toHints-) where+{-# LANGUAGE GADTs #-} -- To pattern match on 'ContextFormat' constructors.+{-# LANGUAGE DeriveAnyClass #-} -- To derive 'Exception' w/o a standalone declaration.+{-# LANGUAGE FlexibleInstances #-} -- To derive 'Exception [WindowHint]'.+-- | Internal module for generating and assessing GLFW hint lists+module Graphics.GPipe.Context.GLFW.Format where -import qualified "GLFW-b" Graphics.UI.GLFW as GLFW-import qualified Graphics.GPipe.Format as F+-- stdlib+import Control.Exception (Exception)+-- third party+import qualified Graphics.UI.GLFW as GLFW+import qualified Graphics.GPipe as GPipe+import Graphics.UI.GLFW (WindowHint(..)) ---------------------------------------------------------------------------------- Top-level+-- | IO Exception thrown when attempting to create a new window using GLFW+-- hints which GPipe manages.+data UnsafeWindowHintsException = UnsafeWindowHintsException [WindowHint]+    deriving+    ( Exception+    , Show+    )+instance Exception [WindowHint] -toHints :: F.ContextFormat c ds -> [GLFW.WindowHint]-toHints fmt =+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++unconditionalHints :: [GLFW.WindowHint]+unconditionalHints =+    [ GLFW.WindowHint'ContextVersionMajor 3+    , GLFW.WindowHint'ContextVersionMinor 3+    , GLFW.WindowHint'OpenGLForwardCompat True+    , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core+    ]++bitsToHints :: Maybe GPipe.WindowBits -> [GLFW.WindowHint]+bitsToHints Nothing = [GLFW.WindowHint'Visible False]+bitsToHints (Just ((red, green, blue, alpha, sRGB), depth, stencil)) =     [ 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

@@ -0,0 +1,329 @@+{-# LANGUAGE TypeFamilies #-} -- To define types in the ContextHandler instance+{-# LANGUAGE DeriveAnyClass #-} -- To derive 'Exception' w/o a standalone declaration.+{-# LANGUAGE TypeSynonymInstances #-} -- To derive 'Exception String'.+{-# LANGUAGE FlexibleInstances #-} -- To derive 'Exception String'.+-- | Internal module defining handler and its ContextHandler instance as well as some methods+module Graphics.GPipe.Context.GLFW.Handler where++-- stdlib+import Control.Monad (forM_, forM)+import Text.Printf (printf)+import Data.List (partition, delete)+import Data.Maybe (fromMaybe)+import Control.Monad (when, unless, void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Exception (Exception, throwIO)+import Control.Concurrent.Async (withAsync)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar+    ( TVar, newTVarIO, readTVarIO, writeTVar, modifyTVar+    )+import Control.Concurrent+    ( MVar, newMVar, modifyMVar_, withMVar+    , ThreadId, myThreadId+    )+-- thirdparty+import qualified Graphics.GPipe.Context as GPipe (ContextHandler(..), Window(), ContextT(), withContextWindow)+import qualified Graphics.UI.GLFW as GLFW (Window, ErrorCallback)+-- local+import qualified Graphics.GPipe.Context.GLFW.Calls as Call+import qualified Graphics.GPipe.Context.GLFW.Format as Format+import qualified Graphics.GPipe.Context.GLFW.RPC as RPC+import qualified Graphics.GPipe.Context.GLFW.Resource as Resource+import Graphics.GPipe.Context.GLFW.Resource (defaultWindowConfig) -- in scope for haddock++bug :: String -> IO ()+bug s = Call.debug s >> throwIO s++-- | Internal handle for a GPipe-created GLFW window/context+data Context = Context+    { contextRaw :: GLFW.Window+--  , contextComm :: RPC.Handle+--  , contextAsync :: Async ()+    }+-- | Closeable internal handle for 'Context'.+type MMContext = MVar (Maybe Context)++-- | Opaque handle representing the initialized GLFW library.+--+-- To get started quickly try 'defaultHandleConfig' and 'defaultWindowConfig'.+--+-- @+--      import Graphics.GPipe+--      import qualified Graphics.GPipe.Context.GLFW as GLFW+--+--      runContextT GLFW.defaultHandleConfig $ do+--          win <- newWindow (WindowFormatColorDepth RGB8 Depth16) (GLFW.defaultWindowConfig "OpenGL Graphics")+--          -- Do GPipe things here+-- @+data Handle = Handle+    { handleTid :: ThreadId+    , handleComm :: RPC.Handle+    , handleCtxs :: TVar [MMContext]+    , handleEventPolicy :: Maybe EventPolicy+    }++-- | Opaque handle representing a, possibly closed, internal 'Context'. You'll+-- typically deal with GPipe's @Window@ instead of this one.+newtype GLFWWindow = WWindow (MMContext, Handle)++-- | Run the action with the context /if the context is still open/.+withContext :: String -> MMContext -> (Context -> IO a) -> IO (Maybe a)+withContext callerTag mmContext action = withMVar mmContext go+    where+        go Nothing = Call.debug (printf "%s: GPipe-GLFW context already closed" callerTag) >> return Nothing+        go (Just context) = pure <$> action context++-- FIXME: May cause crashes in windows (os) because windows (os) requires parent contexts to be uncurrent; easy fix+-- | Run the action. If any open context is avaiable, take it and pass it into the action.+withAnyContext :: Handle -> (Maybe Context -> IO a) -> IO a+withAnyContext handle action = readTVarIO (handleCtxs handle) >>= go+    where+        go (mmContext:ctxs) = withContext "withAnyContext" mmContext (action . pure) >>= maybe (go ctxs) return+        go [] = action Nothing++-- | Template for "Run the action with XYZ /if the gpipe window still exists and ABC/."+unwrappingGPipeWindow :: MonadIO m+    => (String -> action -> Handle -> MMContext -> IO (Maybe a)) -- ^ Specialize use of unwrappingGPipeWindow+    -> String -> GPipe.Window os c ds -> action -> GPipe.ContextT Handle os m (Maybe a)+unwrappingGPipeWindow specialize callerTag wid action = GPipe.withContextWindow wid go+    where+        go Nothing = Call.debug (printf "%s: GPipe had no such window" callerTag) >> return Nothing+        go (Just (WWindow (mmContext, handle))) = specialize callerTag action handle mmContext++-- | Run the action with the context __handle__ /if the gpipe window still exists/.+withHandleFromGPipe :: MonadIO m => String -> GPipe.Window os c ds -> (Handle -> IO a) -> GPipe.ContextT Handle os m (Maybe a)+withHandleFromGPipe = unwrappingGPipeWindow $ \_callerTag action handle _mmContext ->+    Just <$> action handle++---- | Run the action with the __context__ /if the gpipe window still exists and corresponding context is still open/.+withContextFromGPipe :: MonadIO m => String -> GPipe.Window os c ds -> (Context -> IO a) -> GPipe.ContextT Handle os m (Maybe a)+withContextFromGPipe = unwrappingGPipeWindow $ \callerTag action _handle mmContext ->+    withContext callerTag mmContext action++withBothFromGPipe :: MonadIO m => String -> GPipe.Window os c ds -> (Handle -> Context -> IO a) -> GPipe.ContextT Handle os m (Maybe a)+withBothFromGPipe = unwrappingGPipeWindow $ \callerTag action handle mmContext ->+    withContext callerTag mmContext (action handle)++-- | Route an effect to the main thread.+effectMain :: Handle -> Call.EffectMain+effectMain handle = RPC.sendEffect (handleComm handle)++-- | Route an action with a result to the main thread.+onMain :: Handle -> Call.OnMain a+onMain handle = RPC.fetchResult (handleComm handle)++-- | Default GLFW handle configuration.+--+-- * Print any errors that GLFW emits.+-- * Automatically process GLFW events after every buffer swap.+defaultHandleConfig :: GPipe.ContextHandlerParameters Handle+defaultHandleConfig = HandleConfig errorHandler $ pure Poll+    where+        -- TODO: swap printf for some logger+        errorHandler err desc = printf "%s: %s\n" (show err) desc++instance GPipe.ContextHandler Handle where++    -- | Configuration for the GLFW handle.+    data ContextHandlerParameters Handle = HandleConfig+        { -- | Specify a callback to handle errors captured by GLFW.+          configErrorCallback :: GLFW.ErrorCallback+          -- | Specify the 'EventPolicy' to use for automatic GLFW event+          -- processing. Set to 'Nothing' to disable automatic event processing+          -- (you'll need to call 'mainloop' or 'mainstep').+        , configEventPolicy :: Maybe EventPolicy+        }++    type ContextWindow Handle = GLFWWindow+    type WindowParameters Handle = Resource.WindowConfig++    -- Thread assumption: any thread+    --+    -- Create a context which shares objects with the contexts created by this+    -- handle, if any.+    createContext handle settings = do+        unless (null disallowedHints) $+            throwIO $ Format.UnsafeWindowHintsException disallowedHints+        -- make a context+        window <- withAnyContext handle $ \parent -> do+            windowHuh <- Call.createWindow (onMain handle) width height title monitor hints (contextRaw <$> parent)+            Call.debug $ printf "contextCreate made %s -> parent %s" (show windowHuh) (show $ contextRaw <$> parent)+            case (windowHuh, parent) of+                (Just w, _) -> return w+                (Nothing, Just _) -> throwIO . CreateSharedWindowException . show $ config {Resource.configHints = hints}+                (Nothing, Nothing) -> throwIO . CreateWindowException . show $ config {Resource.configHints = hints}+        -- set up context+        forM_ intervalHuh $ \interval -> do+            Call.makeContextCurrent "apply vsync setting" $ pure window+            Call.swapInterval interval+        -- wrap up context+        mmContext <- newMVar . pure $ Context window+        atomically $ modifyTVar (handleCtxs handle) (mmContext :)+        return $ WWindow (mmContext, handle)+        where+            config = fromMaybe (defaultWindowConfig "") (snd <$> settings)+            Resource.WindowConfig {Resource.configWidth=width, Resource.configHeight=height} = config+            Resource.WindowConfig _ _ title monitor _ intervalHuh = config+            (userHints, disallowedHints) = partition Format.allowedHint $ Resource.configHints config+            hints = userHints ++ Format.bitsToHints (fst <$> settings) ++ Format.unconditionalHints++    -- Threading assumption: any thread+    --+    -- Do work with the specified context by making it current. If no context+    -- is specified, then any context being current is sufficient.+    --+    -- XXX: If there's a lot of context swapping, change this to RPC to a+    -- context-private thread running a mainloop.+    contextDoAsync _ Nothing _action = do+        Call.debug "TODO: contextDoAsync called w/o context; ensure any context is current"+    contextDoAsync _ (Just (WWindow (mmContext, _))) action =+        void $ withContext "contextDoAsync" mmContext $ \context -> do+            Call.makeContextCurrent "contextDoAsync required it" . pure . contextRaw $ context+            action++    -- Threading assumption: main thread+    --+    -- Swap buffers for the specified context. If an event policy is set,+    -- process events.+    contextSwap _ (WWindow (mmContext, handle)) = do+        void $ withContext "contextSwap" mmContext $ Call.swapBuffers . contextRaw+        mapM_ (mainstepInternal handle) $ handleEventPolicy handle++    -- Threading assumption: same thread as contextCreate for the given context+    --+    -- Fetch framebuffer size for the specified context by RPCing the main thread.+    contextFrameBufferSize _ (WWindow (mmContext, handle)) = do+        result <- withContext "contextFrameBufferSize" mmContext $ \context -> do+            Call.getFramebufferSize (onMain handle) $ contextRaw context+        maybe failure return result+        where+            failure = do+                Call.debug $ printf "contextFrameBufferSize could not access context"+                return (0, 0)++    -- Threading assumption: same thread as contextCreate for the given context+    --+    -- Destroy the given context by making it current on the main thread and+    -- then destroying it there.+    --+    -- Note: See the restrictions for Call.destroyWindow+    contextDelete _ (WWindow (mmContext, handle)) = do+        -- close the context mvar+        modifyMVar_ mmContext $ \mContext -> do+            Call.debug $ printf "contextDelete of %s" (show $ contextRaw <$> mContext)+            forM_ mContext $ \context -> RPC.sendEffect (handleComm handle) $ do+                Call.makeContextCurrent "contextDelete" . pure . contextRaw $ context+                Call.destroyWindow id (contextRaw context) -- id RPC because this is in a mainthread RPC+            return Nothing+        -- remove the context from the handle+        atomically $ modifyTVar (handleCtxs handle) (delete mmContext)++    -- Threading assumption: main thread+    contextHandlerCreate config = do+        Call.debug "contextHandlerCreate"+        -- make handle resources+        tid <- myThreadId+        comm <- RPC.newBound+        ctxs <- newTVarIO []+        -- initialize glfw+        Call.setErrorCallback id $ pure errorHandler -- id RPC because contextHandlerCreate is called only on mainthread+        ok <- Call.init id -- id RPC because contextHandlerCreate is called only on mainthread+        unless ok $ throwIO InitException+        -- wrap up handle+        return $ Handle tid comm ctxs eventPolicy+        where+            HandleConfig errorHandler eventPolicy = config++    -- Threading: main thread+    contextHandlerDelete handle = do+        Call.debug "contextHandlerDelete"+        ctxs <- readTVarIO $ handleCtxs handle+        forM_ ctxs $ \mmContext -> GPipe.contextDelete handle (WWindow (mmContext, handle))+        atomically $ writeTVar (handleCtxs handle) []+        -- all resources are released+        Call.terminate id -- id RPC because contextHandlerDelete is called only on mainthread+        Call.setErrorCallback id Nothing -- id RPC because contextHandlerDelete is called only on mainthread++-- | Type to describe the waiting or polling style of event processing+-- supported by GLFW.+--+-- * Recommended reading: /Event Processing/ section of the GLFW /Input Guide/+-- at <http://www.glfw.org/docs/latest/input_guide.html#events>.+data EventPolicy+    = Poll+    | Wait+    deriving+    ( Show+    )++-- | Process GLFW and GPipe events according to the given 'EventPolicy'.+--+-- __Use case:__ Call 'mainstep' as part of a custom engine loop in multithreaded+-- applications which do GPipe rendering off of the main thread. Use 'mainloop'+-- for less complex applications.+--+-- * Must be called on the main thread.+-- * Can be called with /any/ window you've created and not yet deleted.+-- * If GPipe can't find the window you passed in, returns 'Nothing'.+mainstep :: MonadIO m+    => GPipe.Window os c ds+    -> EventPolicy -- ^ 'Poll' will process events and return immediately while 'Wait' will sleep until events are received.+    -> GPipe.ContextT Handle os m (Maybe ())+mainstep win eventPolicy = withHandleFromGPipe "mainstep" win $ liftIO . flip mainstepInternal eventPolicy++mainstepInternal :: Handle -> EventPolicy -> IO ()+mainstepInternal handle eventPolicy = do+    tid <- myThreadId+    when (tid /= handleTid handle) $+        bug "mainstep must be called from main thread"+    case eventPolicy of+        Poll -> Call.pollEvents id -- id RPC because mainstepInternal is called only on mainthread+        Wait -> withAsync+                    -- Async sleeps on RPC chan, waking op main when RPC received+                    (RPC.awaitActions (handleComm handle) >> Call.postEmptyEvent)+                    -- Main sleeps on waitEvents+                    (const $ Call.waitEvents id) -- id RPC because mainstepInternal is called only on mainthread+    RPC.processActions $ handleComm handle++-- | Process GLFW and GPipe events according to the given 'EventPolicy' in a+-- loop.+--+-- __Use case:__ Call 'mainloop' in multithreaded applications which do GPipe+-- rendering off of the main thread, but which do not otherwise need additional+-- control over the main thread. For less complex applications use automatic+-- event processing configured via 'HandleConfig'.+--+-- * Must be called on the main thread.+-- * The loop will run until 'windowShouldClose' is true for the all 'Window's+-- created by the same 'ContextHandler', or all the 'Window's have been+-- deleted.+-- * To indicate a window should close use 'setWindowShouldClose' in "Graphics.GPipe.Context.GLFW.Wrapped".+mainloop :: MonadIO m+    => GPipe.Window os c ds+    -> EventPolicy -- ^ A 'Poll' loop runs continuously while a 'Wait' loop sleeps until events or user input occur.+    -> GPipe.ContextT Handle os m (Maybe ())+mainloop win eventPolicy = withHandleFromGPipe "mainloop" win $ liftIO . flip mainloopInternal eventPolicy++mainloopInternal :: Handle -> EventPolicy -> IO ()+mainloopInternal handle eventPolicy = do+    mainstepInternal handle eventPolicy+    ctxs <- readTVarIO $ handleCtxs handle+    allShouldClose <- and <$> forM ctxs oneShouldClose+    unless allShouldClose $+        mainloopInternal handle eventPolicy+    where+        oneShouldClose mmContext = do+            shouldCloseHuh <- withContext "oneShouldClose" mmContext $ Call.windowShouldClose . contextRaw+            return $ fromMaybe True shouldCloseHuh++-- | IO exception thrown when GLFW library initialization fails.+data InitException = InitException+    deriving (Exception, Show)++-- | IO Exception thrown when GLFW window creation fails.+data CreateWindowException+    = CreateWindowException String+    | CreateSharedWindowException String+    deriving (Exception, Show)+instance Exception String

@@ -1,19 +1,23 @@--- | This module exposes much of the functionality that GLFW the __Input guide__ documents:+-- | User input functions covering much of the GLFW __Input guide__: -- <http://www.glfw.org/docs/latest/input_guide.html>.--- Actions are in the GPipe 'ContextT' monad when a window handle is required,--- otherwise they are bare IO actions.--- It is recommended to read about GLFW input handling as it pertains to your domain,--- especially the __Event processing__ section:--- <http://www.glfw.org/docs/latest/input_guide.html#events>.+-- For additional functionality see "Graphics.GPipe.Context.GLFW.Wrapped".+--+-- Actions are in the GPipe 'GPipe.ContextT' monad when a window handle is required,+-- otherwise they are bare reexported IO actions which can be lifted into the 'GPipe.ContextT' monad.+-- The 'Window' taken by many of these functions is the window resource from GPipe.  module Graphics.GPipe.Context.GLFW.Input (   -- * Event processing  -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#events- GLFW.pollEvents,- -- | Process received events and return; for applications which continually render.- GLFW.waitEvents,- -- | Sleep until an event is received; for applications which update in response to user input.+ --+ --     * `glfwPollEvents`+ --     * `glfwWaitEvents`+ --+ -- GLFW Events are processed after each buffer swap by default. To change+ -- event processing construct a 'HandleConfig' for 'runContextT'. For greater+ -- control use the 'mainloop' and 'mainstep' functions provided by+ -- "Graphics.GPipe.Context.GLFW".  GLFW.postEmptyEvent,  -- | Force wake from 'waitEvents' with a dummy event. @@ -121,7 +125,7 @@  JoystickButtonState(..),   -- * Not supported- -- | Some GLFW functionality isn't currently exposed by "GLFW-b".+ -- | Some GLFW functionality isn't currently exposed by "Graphics.UI.GLFW".  --  --     * `glfwWaitEventsTimeout`  --     * `glfwSetCharModsCallback`@@ -129,17 +133,12 @@  --     * `glfwSetJoystickCallback`  --     * `glfwGetTimerValue`  --     * `glfwGetTimerFrequency`-- -- * Deprecated- GLFW.ScrollCallback,- registerScrollCallback,- windowShouldClose,  ) where -import Graphics.GPipe.Context.GLFW.Unsafe (GLFWWindow(..))-+-- stdlib import Control.Monad.IO.Class (MonadIO)-import Graphics.GPipe.Context (ContextT, withContextWindow)+import qualified Graphics.GPipe.Context as GPipe (ContextT, Window())+-- third party import qualified Graphics.UI.GLFW as GLFW import Graphics.UI.GLFW (  Key(..),@@ -156,96 +155,84 @@  Joystick(..),  JoystickButtonState(..),  )+-- local+import Graphics.GPipe.Context.GLFW.Handler (Handle(..))+import Graphics.GPipe.Context.GLFW.Wrappers+import qualified Graphics.GPipe.Context.GLFW.Calls as Call -{- Util -} --- | Convenience function to access the unwrapped GLFW window.-withWindow :: MonadIO m => (GLFW.Window -> IO a) -> ContextT GLFWWindow os f m a-withWindow f = withContextWindow $ f . getGLFWWindow---- | Convenience function to quickly wrap two argument functions taking window and something else.--- Wrapped functions don't take window.-wrapWindowFun :: MonadIO m => (GLFW.Window -> a -> IO b) -> a -> ContextT GLFWWindow os f m b-wrapWindowFun f x = withWindow $ \w -> f w x---- | Convenience function to quickly wrap callback setters taking window and passing window to the callback.--- Wrapped functions don't take window.--- Callbacks don't receive window /it is eaten by `const`/.-wrapCallbackSetter :: (MonadIO m, Functor g) => (GLFW.Window -> g (GLFW.Window -> b) -> IO a) -> g b -> ContextT GLFWWindow os f m a-wrapCallbackSetter setter cb = withWindow $ \w -> setter w (const <$> cb)- {- Keyboard -}  -- | Register or unregister a callback to receive 'KeyState' changes to any 'Key'.-setKeyCallback :: MonadIO m => Maybe (Key -> Int -> KeyState -> ModifierKeys -> IO ()) -> ContextT GLFWWindow os f m ()-setKeyCallback = wrapCallbackSetter GLFW.setKeyCallback+setKeyCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (Key -> Int -> KeyState -> ModifierKeys -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setKeyCallback = wrapCallbackSetter Call.setKeyCallback  -- | Poll for the 'KeyState' of a 'Key'.-getKey :: MonadIO m => Key -> ContextT GLFWWindow os f m KeyState-getKey = wrapWindowFun GLFW.getKey+getKey :: MonadIO m => GPipe.Window os c ds -> Key -> GPipe.ContextT Handle os m (Maybe KeyState)+getKey = wrapWindowFun Call.getKey  -- | Polling a 'Key' for 'KeyState' may sometimes miss state transitions. -- If you use cannot use a callback to receive 'KeyState' changes, -- use 'getKey' in combination with GLFW's sticky-keys feature: -- <http://www.glfw.org/docs/latest/input_guide.html#input_key>.-setStickyKeysInputMode :: MonadIO m => StickyKeysInputMode -> ContextT GLFWWindow os f m ()-setStickyKeysInputMode = wrapWindowFun GLFW.setStickyKeysInputMode+setStickyKeysInputMode :: MonadIO m => GPipe.Window os c ds -> StickyKeysInputMode -> GPipe.ContextT Handle os m (Maybe ())+setStickyKeysInputMode = wrapWindowFun Call.setStickyKeysInputMode -getStickyKeysInputMode :: MonadIO m => ContextT GLFWWindow os f m StickyKeysInputMode-getStickyKeysInputMode = withWindow GLFW.getStickyKeysInputMode+getStickyKeysInputMode :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe StickyKeysInputMode)+getStickyKeysInputMode = withWindowRPC Call.getStickyKeysInputMode  -- | Register or unregister a callback to receive character input obeying keyboard layouts and modifier effects.-setCharCallback :: MonadIO m => Maybe (Char -> IO ()) -> ContextT GLFWWindow os f m ()-setCharCallback = wrapCallbackSetter GLFW.setCharCallback+setCharCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (Char -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setCharCallback = wrapCallbackSetter Call.setCharCallback  {- Mouse -}  -- | Register or unregister a callback to receive mouse location changes. -- Callback receives `x` and `y` position measured in screen-coordinates relative to the top left of the GLFW window.-setCursorPosCallback :: MonadIO m => Maybe (Double -> Double -> IO ()) -> ContextT GLFWWindow os f m ()-setCursorPosCallback = wrapCallbackSetter GLFW.setCursorPosCallback+setCursorPosCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (Double -> Double -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setCursorPosCallback = wrapCallbackSetter Call.setCursorPosCallback  -- | Poll for the location of the mouse.-getCursorPos :: MonadIO m => ContextT GLFWWindow os f m (Double, Double)-getCursorPos = withWindow GLFW.getCursorPos+getCursorPos :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe (Double, Double))+getCursorPos = withWindowRPC Call.getCursorPos  -- | GLFW supports setting cursor mode to support mouselook and other advanced uses of the mouse: -- <http://www.glfw.org/docs/latest/input_guide.html#cursor_mode>.-setCursorInputMode :: MonadIO m => CursorInputMode -> ContextT GLFWWindow os f m ()-setCursorInputMode = wrapWindowFun GLFW.setCursorInputMode+setCursorInputMode :: MonadIO m => GPipe.Window os c ds -> CursorInputMode -> GPipe.ContextT Handle os m (Maybe ())+setCursorInputMode = wrapWindowFun Call.setCursorInputMode -getCursorInputMode :: MonadIO m => ContextT GLFWWindow os f m CursorInputMode-getCursorInputMode = withWindow GLFW.getCursorInputMode+getCursorInputMode :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe CursorInputMode)+getCursorInputMode = withWindowRPC Call.getCursorInputMode  -- | Set the cursor to be displayed over the window while 'CursorInputMode' is `Normal`.-setCursor :: MonadIO m => Cursor -> ContextT GLFWWindow os f m ()-setCursor = wrapWindowFun GLFW.setCursor+setCursor :: MonadIO m => GPipe.Window os c ds -> Cursor -> GPipe.ContextT Handle os m (Maybe ())+setCursor = wrapWindowFun Call.setCursor  -- | Register or unregister a callback to receive 'CursorState' changes when the cursor enters or exits the window.-setCursorEnterCallback :: MonadIO m => Maybe (CursorState -> IO ()) -> ContextT GLFWWindow os f m ()-setCursorEnterCallback = wrapCallbackSetter GLFW.setCursorEnterCallback+setCursorEnterCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (CursorState -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setCursorEnterCallback = wrapCallbackSetter Call.setCursorEnterCallback  -- | Register or unregister a callback to receive 'MouseButtonState' changes to a 'MouseButton'.-setMouseButtonCallback :: MonadIO m => Maybe (MouseButton -> MouseButtonState -> ModifierKeys -> IO ()) -> ContextT GLFWWindow os f m ()-setMouseButtonCallback = wrapCallbackSetter GLFW.setMouseButtonCallback+setMouseButtonCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (MouseButton -> MouseButtonState -> ModifierKeys -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setMouseButtonCallback = wrapCallbackSetter Call.setMouseButtonCallback  -- | Poll for the 'MouseButtonState' of a 'MouseButton'.-getMouseButton :: MonadIO m => MouseButton -> ContextT GLFWWindow os f m MouseButtonState-getMouseButton = wrapWindowFun GLFW.getMouseButton+getMouseButton :: MonadIO m => GPipe.Window os c ds -> MouseButton -> GPipe.ContextT Handle os m (Maybe MouseButtonState)+getMouseButton = wrapWindowFun Call.getMouseButton  -- | Polling a 'MouseButton' for 'MouseButtonState' may sometimes miss state transitions. -- If you use cannot use a callback to receive 'MouseButtonState' changes, -- use 'getMouseButton' in combination with GLFW's sticky-mouse-buttons feature: -- <http://www.glfw.org/docs/latest/input_guide.html#input_mouse_button>.-setStickyMouseButtonsInputMode :: MonadIO m => StickyMouseButtonsInputMode -> ContextT GLFWWindow os f m ()-setStickyMouseButtonsInputMode = wrapWindowFun GLFW.setStickyMouseButtonsInputMode+setStickyMouseButtonsInputMode :: MonadIO m => GPipe.Window os c ds -> StickyMouseButtonsInputMode -> GPipe.ContextT Handle os m (Maybe ())+setStickyMouseButtonsInputMode = wrapWindowFun Call.setStickyMouseButtonsInputMode -getStickyMouseButtonsInputMode :: MonadIO m => ContextT GLFWWindow os f m StickyMouseButtonsInputMode-getStickyMouseButtonsInputMode = withWindow GLFW.getStickyMouseButtonsInputMode+getStickyMouseButtonsInputMode :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe StickyMouseButtonsInputMode)+getStickyMouseButtonsInputMode = withWindowRPC Call.getStickyMouseButtonsInputMode  -- | Register or unregister a callback to receive scroll offset changes.-setScrollCallback :: MonadIO m => Maybe (Double -> Double -> IO ()) -> ContextT GLFWWindow os f m ()-setScrollCallback = wrapCallbackSetter GLFW.setScrollCallback+setScrollCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (Double -> Double -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setScrollCallback = wrapCallbackSetter Call.setScrollCallback  {- Joystick -} @@ -254,27 +241,15 @@ {- Clipboard -}  -- | Poll the system clipboard for a UTF-8 encoded string, if one can be extracted.-getClipboardString :: MonadIO m => ContextT GLFWWindow os f m (Maybe String)-getClipboardString = withWindow GLFW.getClipboardString+getClipboardString :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe (Maybe String))+getClipboardString = withWindowRPC Call.getClipboardString  -- | Store a UTF-8 encoded string in the system clipboard.-setClipboardString :: MonadIO m => String -> ContextT GLFWWindow os f m ()-setClipboardString = wrapWindowFun GLFW.setClipboardString+setClipboardString :: MonadIO m => GPipe.Window os c ds -> String -> GPipe.ContextT Handle os m (Maybe ())+setClipboardString = wrapWindowFun Call.setClipboardString  {- Pathdrop -}  -- | Register or unregister a callback to receive file paths when files are dropped onto the window.-setDropCallback :: MonadIO m => Maybe ([String] -> IO ()) -> ContextT GLFWWindow os f m ()-setDropCallback = wrapCallbackSetter GLFW.setDropCallback--{- Deprecated -}---- | Register or unregister a 'ScrollCallback' to receive scroll events.--- Deprecated and will be removed. Prefer to use 'setScrollCallback'.-registerScrollCallback :: MonadIO m => Maybe GLFW.ScrollCallback -> ContextT GLFWWindow os f m ()-registerScrollCallback callback = withWindow $ \w -> GLFW.setScrollCallback w callback---- | Returns 'True' if the window should close (e.g. because the user pressed the \'x\' button).--- Deprecated and will be moved to a different module.-windowShouldClose :: MonadIO m => ContextT GLFWWindow os f m Bool-windowShouldClose = withWindow GLFW.windowShouldClose+setDropCallback :: MonadIO m => GPipe.Window os c ds -> Maybe ([String] -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setDropCallback = wrapCallbackSetter Call.setDropCallback

@@ -0,0 +1,71 @@+module Graphics.GPipe.Context.GLFW.RPC where++-- stdlib+import Data.Sequence (Seq, (|>), empty)+import Control.Concurrent (ThreadId, myThreadId)+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Concurrent.STM (STM, atomically)+import Control.Concurrent.STM.TQueue+    ( TQueue, newTQueue, writeTQueue, tryReadTQueue, peekTQueue+    )+-- local+--import qualified Graphics.GPipe.Context.GLFW.Calls as Call++data Handle = Handle ThreadId (TQueue RPC)+    deriving+    ( Eq+    )++-- TODO: change RPC to a chan of `IO ()` and collapse `runActions`+data RPC+    = Execute (IO ())+    | Noop++-- | Create an RPC handle bound to the current thread. Actions sent from the+-- bound thread will just be run w/o doing an RPC.+newBound :: IO Handle+newBound = do+    tid <- myThreadId+    comm <- atomically $ newTQueue+    return $ Handle tid comm++-- XXX: consider pushing thread-check to all callsites of sendEffect, fetchResult+-- TODO: dry-up thread id check+sendEffect :: Handle -> IO () -> IO ()+sendEffect (Handle boundTid comm) action = do+    tid <- myThreadId+    if boundTid == tid+        then action+        else atomically $ writeTQueue comm (Execute action)++fetchResult :: Handle -> IO a -> IO a+fetchResult (Handle boundTid comm) action = do+    tid <- myThreadId+    if boundTid == tid+        then action+        else do+            reply <- newEmptyMVar+            -- XXX: Make sure the value put in the MVar is evaluated first+            atomically$ writeTQueue comm (Execute $ action >>= putMVar reply)+            takeMVar reply++drainComm :: TQueue a -> STM (Seq a)+drainComm queue = go empty+    where+        go rpcs = do+            result <- tryReadTQueue queue+            case result of+                Just rpc -> go $ rpcs |> rpc+                Nothing -> return rpcs++runActions :: Foldable t => t RPC -> IO ()+runActions actions = mapM_ go actions+    where+        go Noop = print "noop"+        go (Execute action) = action++awaitActions :: Handle -> IO RPC+awaitActions (Handle _ comm) = atomically . peekTQueue $ comm++processActions :: Handle -> IO ()+processActions (Handle _ comm) = (atomically . drainComm $ comm) >>= runActions

@@ -1,116 +1,24 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE CPP #-}--- | Bracketed GLFW resource initializers.-module Graphics.GPipe.Context.GLFW.Resource-( newContext-, newSharedContext-, WindowConf(..)-, GLFWWindow(..)-, defaultWindowConf-, 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--#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---- a default error callback which ragequits-defaultOnError :: ErrorCallback-defaultOnError err msg = fail $ P.printf "%s: %s" (show err) msg---- | 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"----------------------------------------------------------------------------------- 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+-- | Internal module defining resources and associated types+module Graphics.GPipe.Context.GLFW.Resource where --- 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+-- thirdparty+import qualified Graphics.UI.GLFW as GLFW+    ( Monitor+    , WindowHint+    ) --- establish a *shared* opengl context-newSharedContext :: Window -> [GLFW.WindowHint] -> Maybe WindowConf -> IO Window-newSharedContext ctx hints wc-    = withHints hints-    $ newWindow (Just ctx) wc+-- | Configuration for a new GLFW window and associated OpenGL context.+data WindowConfig = WindowConfig+    { configWidth :: Int+    , configHeight :: Int+    , configTitle :: String+    , configMonitor :: Maybe GLFW.Monitor+    , configHints :: [GLFW.WindowHint]+    , configSwapInterval :: Maybe Int+    } deriving+    ( Show+    ) --- eof+-- | Default window configuration for a small window on any monitor with the given title.+defaultWindowConfig :: String -> WindowConfig+defaultWindowConfig title = WindowConfig 640 480 title Nothing [] Nothing

@@ -1,20 +0,0 @@--- | 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(..))

@@ -1,19 +0,0 @@-{-# 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 = GLFW.swapBuffers--getFramebufferSize :: GLFW.Window -> IO (Int, Int)-getFramebufferSize = GLFW.getFramebufferSize---- eof

@@ -0,0 +1,19 @@+-- | Wrapped calls to GLFW-b for application programmer use. For user input see+-- "Graphics.GPipe.Context.GLFW.Input".+--+-- Actions are in the GPipe 'GPipe.ContextT' monad when a window handle is required,+-- otherwise they are bare reexported IO actions which can be lifted into the 'GPipe.ContextT' monad.+-- The 'Window' taken by many of these functions is the window resource from GPipe.+module Graphics.GPipe.Context.GLFW.Wrapped where++-- stdlib+import Control.Monad.IO.Class (MonadIO)+-- thirdparty+import qualified Graphics.GPipe.Context as GPipe (ContextT, Window())+-- local+import Graphics.GPipe.Context.GLFW.Handler (Handle(..))+import qualified Graphics.GPipe.Context.GLFW.Calls as Call+import qualified Graphics.GPipe.Context.GLFW.Wrappers as Wrappers++windowShouldClose :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe Bool)+windowShouldClose = Wrappers.withWindow Call.windowShouldClose

@@ -0,0 +1,34 @@+-- | Internal module supporting "Graphics.GPipe.Context.GLFW.Input" and "Graphics.GPipe.Context.GLFW.Wrapped"+module Graphics.GPipe.Context.GLFW.Wrappers where++-- stdlib+import Control.Monad.IO.Class (MonadIO)+-- thirdparty+import qualified Graphics.UI.GLFW as GLFW+import qualified Graphics.GPipe.Context as GPipe (ContextT, Window())+-- local+import qualified Graphics.GPipe.Context.GLFW.Handler as Handler+import qualified Graphics.GPipe.Context.GLFW.Calls as Call+import qualified Graphics.GPipe.Context.GLFW.RPC as RPC++-- | Convenience funcion to run the action with the context if GPipe can locate it and it is still open.+withWindow :: MonadIO m => (GLFW.Window -> IO a) -> GPipe.Window os c ds -> GPipe.ContextT Handler.Handle os m (Maybe a)+withWindow fun wid = Handler.withContextFromGPipe "withWindowNoRPC" wid go+    where+        go = fun . Handler.contextRaw++-- | Convenience function to look up and unwrap the GLFW window and route the GLFW function through RPC.+withWindowRPC :: MonadIO m => (Call.OnMain a -> GLFW.Window -> IO a) -> GPipe.Window os c ds -> GPipe.ContextT Handler.Handle os m (Maybe a)+withWindowRPC fun wid = Handler.withBothFromGPipe "withWindowRPC" wid go+    where+        go handle = fun (RPC.fetchResult . Handler.handleComm $ handle) . Handler.contextRaw++-- | Convenience function to wrap two-argument functions taking window and something else.+wrapWindowFun :: MonadIO m => (Call.OnMain b -> GLFW.Window -> a -> IO b) -> GPipe.Window os c ds -> a -> GPipe.ContextT Handler.Handle os m (Maybe b)+wrapWindowFun fun wid x = flip withWindowRPC wid $ \onMain window -> fun onMain window x++-- | Convenience function to wrap callback setters which take window and pass it to the callback.+-- Callbacks will be passed the GPipe window id.+wrapCallbackSetter :: (MonadIO m, Functor g) => (Call.OnMain a -> GLFW.Window -> g (GLFW.Window -> b) -> IO a) -> GPipe.Window os c ds -> g b -> GPipe.ContextT Handler.Handle os m (Maybe a)+wrapCallbackSetter setter wid cb = flip withWindowRPC wid $ \onMain window -> setter onMain window (const <$> cb)+

@@ -1,12 +0,0 @@-import qualified System.Environment as Env-import qualified Test.Basic as Basic-import qualified Test.Split as Split-import qualified Test.Multi as Multi--main :: IO ()-main = do-    putStrLn "\n= Running smoke tests"-    Env.lookupEnv "LIBGL_ALWAYS_SOFTWARE" >>= \val -> putStrLn $ "LIBGL_ALWAYS_SOFTWARE: " ++ show val-    Basic.test (3 * 60)-    Split.test (3 * 60)-    Multi.test (3 * 60)

@@ -1,17 +0,0 @@-module Test.Basic where--import Graphics.GPipe-import qualified Graphics.GPipe.Context.GLFW as GLFW-import qualified Test.Common as C---- Basic Test--test :: Int -> IO ()-test frameCount = do-    putStrLn "== Basic Test"-    putStrLn "\tRender a scene to a window."-    runContextT GLFW.newContext (ContextFormatColorDepth RGB8 Depth16) $ do-        resources <- C.initRenderContext [C.xAxis, C.yAxis, C.zAxis, C.plane]-        C.mainloop (frameCount, 0) resources---- eof

@@ -1,128 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Test.Common where--import Control.Monad.Exception (MonadException)-import Control.Monad.IO.Class (MonadIO)-import Data.Traversable (forM)--import Graphics.GPipe--xAxis :: [(V3 Float, V3 Float)]-xAxis = zip (repeat $ V3 1 0 0) -- red-    [V3 (-1) 0 0, V3 1 0 0, V3 0.8 (-0.1) 0, V3 0.8 0 0, V3 1 (-0.1) 0]--yAxis :: [(V3 Float, V3 Float)]-yAxis = zip (repeat $ V3 0 1 0) -- green-    [V3 0 (-1) 0, V3 0 1 0, V3 0 0.8 (-0.1), V3 0 0.9 (-0.05), V3 0 1 (-0.1)]--zAxis :: [(V3 Float, V3 Float)]-zAxis = zip (repeat $ V3 0 0 1) -- blue-    [V3 0 0 (-1), V3 0 0 1, V3 (-0.1) 0 0.8, V3 (-0.1) 0 1]--plane :: [(V3 Float, V3 Float)]-plane = zip (repeat $ V3 1 1 1) -- white-    [V3 (-2) (-0.1) (-2), V3 (-2) (-0.1) 2, V3 2 (-0.1) 2, V3 2 (-0.1) (-2), V3 (-2) (-0.1) (-2)]---- TODO: make tests---   * basic---   * split-thread load/render---   * render multiple windows--data ShaderEnv os = ShaderEnv-    { extractProjU :: (Buffer os (Uniform (V4 (B4 Float))), Int)-    , extractLinePA :: PrimitiveArray Lines (B3 Float, B3 Float)-    , extractRastOpts :: (Side, ViewPort, DepthRange)-    }--initBuffers-    :: MonadIO m-    => [[(V3 Float, V3 Float)]]-    -> ContextT w os f m ([Buffer os (B3 Float, B3 Float)], Buffer os (Uniform (V4 (B4 Float))))-initBuffers rawMeshes = do-    -- make mesh buffers-    meshesB <- forM rawMeshes $ \pts -> do-        buf <- newBuffer $ length pts-        writeBuffer buf 0 pts-        return buf-    -- make projection matrix buffer-    projMatB <- newBuffer 1-    return (meshesB, projMatB)--projectLines :: forall os f. Shader os f (ShaderEnv os) (FragmentStream (V3 FFloat, FFloat))-projectLines = do-    projMat <- getUniform extractProjU-    linePS <- toPrimitiveStream extractLinePA-    -- project points-    let projectedLinePS = (\(c, p) -> (projMat !* point p, c)) <$> linePS-    lineFS <- rasterize extractRastOpts projectedLinePS-    -- write fragment depths and return frags-    return $ withRasterizedInfo (\fr inf -> (fr, depth inf)) lineFS-    where-        depth RasterizedInfo {rasterizedFragCoord = (V4 _ _ z _)} = z---- TODO: just adds the draw call to the end of the shader & glues some init functions together-initRenderContext-    :: (MonadIO m, MonadException m)-    => [[(V3 Float, V3 Float)]]-    -> ContextT w os (ContextFormat RGBFloat Depth) m-        ( [Buffer os (B3 Float, B3 Float)]-        , Buffer os (Uniform (V4 (B4 Float)))-        , CompiledShader os (ContextFormat RGBFloat Depth) (ShaderEnv os)-        )-initRenderContext rawMeshes = do-    projShader <- compileShader (projectLines >>= drawContextColorDepth (const (ContextColorOption NoBlending $ pure True, DepthOption Less True)))-    (meshesB, projMatB) <- initBuffers rawMeshes-    return (meshesB, projMatB, projShader)--computeProjMat :: Float -> V2 Int -> M44 Float-computeProjMat frac (V2 w h) = camera2clip !*! world2camera !*! model2world-    where-        t = frac * 2 * pi-        model2world = identity-        world2camera = lookAt-            -- eye: camera position in world coordinates-            (V3 (3 * sin t) (0.5 + cos (t * 2)) (3 * cos t))-            (V3 0 0.1 0) -- center: camera look-at target position in world coords-            (V3 0 1 0) -- up: camera up-vector-        camera2clip = perspective-            (pi / 3) -- 60deg field of view "in y direction"-            (fromIntegral w / fromIntegral h) -- aspect ratio-            1 100 -- near and far clipping plane--basicRenderer-    :: V2 Int-    -> ( [Buffer os (B3 Float, B3 Float)]-       , Buffer os (Uniform (V4 (B4 Float)))-       , CompiledShader os (ContextFormat RGBFloat Depth) (ShaderEnv os)-       )-    -> Render os (ContextFormat RGBFloat Depth) ()-basicRenderer size (meshesB, projMatB, projShader) = do-    clearContextColor 0.2 -- grey-    clearContextDepth 1 -- far plane-    meshPAs <- forM meshesB $ \mesh -> do-        meshVA <- newVertexArray mesh-        return $ toPrimitiveArray LineStrip meshVA-    projShader $ ShaderEnv (projMatB, 0) (mconcat meshPAs) (Front, ViewPort 0 size, DepthRange 0 1)--mainloop-    ::  (MonadIO m, MonadException m)-    => (Int, Int)-    -> ( [Buffer os (B3 Float, B3 Float)]-       , Buffer os (Uniform (V4 (B4 Float)))-       , CompiledShader os (ContextFormat RGBFloat Depth) (ShaderEnv os)-       )-    -> ContextT w os (ContextFormat RGBFloat Depth) m ()-mainloop frame resources@(_, projMatB, _)-    | done frame = return ()-    | otherwise = do-        -- compute a projection matrix & write it to the buffer-        size <- getContextBuffersSize-        writeBuffer projMatB 0 [computeProjMat (frac frame) size]-        -- render the scene and then loop-        render $ basicRenderer size resources-        swapContextBuffers-        mainloop (next frame) resources-    where-        done (maxFrame, curFrame) = curFrame > maxFrame-        frac (maxFrame, curFrame) = fromIntegral curFrame / fromIntegral maxFrame-        next = fmap (+1)

@@ -1,16 +0,0 @@-module Test.Multi where--import Graphics.GPipe-import qualified Graphics.GPipe.Context.GLFW as GLFW-import qualified Test.Common as C--test :: Int -> IO ()-test _ = do-    putStrLn "== Multi window test"-    putStrLn "\tUse shared contexts to load resources and render different subsets to different windows."-    runContextT GLFW.newContext (ContextFormatColorDepth RGB8 Depth16) $ do-        -- TODO: in main thread render the axes--        -- TODO: fork; in other thread render just C.plane-        runSharedContextT (ContextFormatColorDepth RGB32F Depth16) $ do-            return ()

@@ -1,18 +0,0 @@-module Test.Split where--import Graphics.GPipe-import qualified Graphics.GPipe.Context.GLFW as GLFW---import qualified Test.Common as C--test :: Int -> IO ()-test _ = do-    putStrLn "== Split thread test"-    putStrLn "\tUse shared contexts to load resources on one thread and render on another."-    runContextT GLFW.newContext (ContextFormatColorDepth RGB8 Depth16) $ do-        -- TODO: in main thread, make buffers but leave them empty--        -- TODO: fork; in other thread change contents of buffers once a second-        runSharedContextT (ContextFormatNone) $ do-            return ()---- eof