packages feed

GPipe-GLFW4 (empty) → 2.0.0

raw patch · 34 files changed

+2360/−0 lines, 34 filesdep +GLFW-bdep +GPipe-Coredep +GPipe-GLFW4setup-changed

Dependencies added: GLFW-b, GPipe-Core, GPipe-GLFW4, JuicyPixels, async, base, containers, criterion, exception-transformers, hspec, lens, stm, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,67 @@+### 2.0.0++- Add support for timed wait using `WaitTimeout` as `EventPolicy` to limit fps.+- Add `setWindowSizeCallback` so that it is no longer necessary to poll for+  window size changes.+- **Potentially breaking change:** Add `configEnableDebug :: Bool` field to the+  `ContextHandlerParameters Handler`/`HandleConfig` data constructor.+- Suppress debug logging by default. Turn it back on with+  `defaultHandleConfig{configEnableDebug = True}` config.+- Move to OpenGL Core Profile 4.5.++### 1.4.1.4++- [sorki](https://github.com/sorki) bumped versions.+- Reworked the nix integration.++### 1.4.1.3++- [MaciekFlis](https://github.com/MaciekFlis) bumped versions and resolver.++### 1.4.1.2++- [Kludgy](https://github.com/Kludgy) bumped versions and resolver.+- [LinuxUser404](https://github.com/LinuxUser404) bumped versions and added `cabal.project` & `.travis.yml`.+- Set up travis builds with stack.++### 1.4.1.1++- Split changelog to own file (before this, it's located in README.md).+- [lambdael](https://github.com/lambdael) added `glfwGetWindowSize`.+- [Bump upper bound on `base` dependency](https://github.com/fpco/stackage/issues/2670). Bump stack LTS.++### 1.4.1++- Split `Wrapped` module to `Window` and `Misc` modules.+- Don't expose `ErrorCallback`, do expose the `Error` type for custom error callbacks.+- Switch from ad-hoc parenting for shared contexts, to the "ancestor" pattern described in [#24](https://github.com/plredmond/GPipe-GLFW/issues/24#issuecomment-299681824).+- Adjustments to debug logging format.+- Add smoketest for window close functions & sequential GPipe windows.+- Bump deps to `GPipe-2.2.1`++### 1.4.0++- Rewrite for new window handling interface.+- Separate smoke tests to own package.++### 1.3.0++- Overhaul `Graphics.GPipe.Context.GLFW.Input` to expose most of the functionality in [GLFW Input guide](http://www.glfw.org/docs/latest/input_guide.html).++### 1.2.3++- [SwiftsNamesake](https://github.com/SwiftsNamesake) bumped version constraints.+- Add a smoke test and stubs for shared-context tests.++### 1.2.2++- [grtlr](https://github.com/grtlr) added scroll callback registration.+- Add a readme to be a good citizen and update documentation.++### 1.2.1++- [bch29](https://github.com/bch29) refactored and added new GLFW input callback registration functions as well as the `unsafe` module to access the GLFW window directly.++### 1.2++- [bch29](https://github.com/bch29) exposed more of the underlying GLFW hints.
+ GPipe-GLFW4.cabal view
@@ -0,0 +1,122 @@+name:           GPipe-GLFW4+version:        2.0.0+cabal-version:  >= 1.10+build-type:     Simple+author:         Patrick Redmond+license:        MIT+license-file:   LICENSE+copyright:      Patrick Redmond+category:       Graphics+stability:      Experimental+homepage:       https://github.com/plredmond/GPipe-GLFW+synopsis:       GLFW OpenGL context creation for GPipe+description:+                GPipe-GLFW is 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.++                This version uses OpenGL Core profile 4.5 and uses GPipe-Core+                instead of GPipe.+maintainer:     Patrick Redmond+data-files:     CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/homectl/workspace+  subdir:   GPipe-GLFW4++library+  hs-source-dirs: src+  ghc-options:+      -Wall+  default-language: Haskell2010+  exposed-modules:+      Graphics.GPipe.Context.GLFW+      Graphics.GPipe.Context.GLFW.Input+      Graphics.GPipe.Context.GLFW.Window+      Graphics.GPipe.Context.GLFW.Misc+  other-modules:+      Graphics.GPipe.Context.GLFW.Calls+      Graphics.GPipe.Context.GLFW.Resource+      Graphics.GPipe.Context.GLFW.Wrappers+      Graphics.GPipe.Context.GLFW.Format+      Graphics.GPipe.Context.GLFW.Handler+      Graphics.GPipe.Context.GLFW.RPC+      Graphics.GPipe.Context.GLFW.Logger+  build-depends:+      base                          >= 4.7 && < 5+    , GLFW-b                        >= 3.2 && < 3.4+    , GPipe-Core                    >= 0.2.3 && < 0.3+    , async                         >= 2.1 && < 2.3+    , containers                    >= 0.5 && < 0.7+    , stm                           >= 2.4 && < 3++test-suite testsuite+  default-language: Haskell2010+  hs-source-dirs:   test+  type: exitcode-stdio-1.0+  main-is:          testsuite.hs+  other-modules:+      Graphics.GPipe.Context.GLFW.CloseSpec+      Graphics.GPipe.Context.GLFW.FixedSpec+      Graphics.GPipe.Context.GLFW.InputSpec+      Graphics.GPipe.Context.GLFW.ManualSpec+      Graphics.GPipe.Context.GLFW.MultiPassSpec+      Graphics.GPipe.Context.GLFW.SequenceSpec+      Graphics.GPipe.Context.GLFW.TimedSpec+      Graphics.GPipe.BufferSpec+      Graphics.GPipe.GeometryStream.IdentitySpec+      Graphics.GPipe.GeometryStream.Shader2DSpec+      Graphics.GPipe.GeometryStream.Shader3DSpec+      Test.Common+      Test.Control+      Test.ShaderTest+  ghc-options:+      -Wall+      -threaded+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base < 5+    , GPipe-Core+    , GPipe-GLFW4+    , exception-transformers+    , hspec+    , lens+    , transformers++benchmark bench+  default-language: Haskell2010+  hs-source-dirs:   bench+  type: exitcode-stdio-1.0+  main-is:          bench.hs+  other-modules:+      Graphics.GPipe.BufferBench+      Graphics.GPipe.TextureBench+  ghc-options:+      -Wall+      -threaded+  build-depends:+      base < 5+    , GPipe-Core+    , GPipe-GLFW4+    , JuicyPixels+    , criterion++executable playground+  default-language: Haskell2010+  hs-source-dirs:   tools, test+  main-is:          playground.hs+  other-modules:+      Test.ShaderTest+  ghc-options:+      -Wall+      -threaded+  build-depends:+      base < 5+    , GPipe-Core+    , GPipe-GLFW4+    , exception-transformers+    , lens+    , transformers
+ 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
+ bench/Graphics/GPipe/BufferBench.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.GPipe.BufferBench (suite) where++import           Criterion.Main              (Benchmark, bench, bgroup, whnfIO)++import           Graphics.GPipe.Buffer++import           Graphics.GPipe.Context      (runContextT)+import qualified Graphics.GPipe.Context.GLFW as GLFW+++benchWriteBuffer :: Int -> IO Int+benchWriteBuffer l =+    runContextT GLFW.defaultHandleConfig $ do+        buf :: Buffer os (B Float) <- newBuffer l+        writeBuffer buf 0 [0..fromIntegral l]+        return $ bufferLength buf+++suite :: IO Benchmark+suite = return $ bgroup "Buffer"+    [ bgroup "writeBuffer"+        [ bench "1000000"  $ whnfIO (benchWriteBuffer 1000000)+        , bench "10000000" $ whnfIO (benchWriteBuffer 10000000)+        ]+    ]
+ bench/Graphics/GPipe/TextureBench.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.GPipe.TextureBench (suite) where++import           Criterion.Main              (Benchmark, bench, bgroup, whnfIO)++import           Graphics.GPipe.Texture++import qualified Codec.Picture               as Pic+import           Graphics.GPipe              (Format (SRGB8), V2 (..), V3 (..))+import           Graphics.GPipe.Context      (runContextT)+import qualified Graphics.GPipe.Context.GLFW as GLFW+++benchWriteTexture2D :: V2 Int -> IO Int+benchWriteTexture2D size@(V2 w h) =+    let pixels = [ V3 (fromIntegral x) (fromIntegral y) 0 :: V3 Pic.Pixel8+                 | y <- [0..h], x <- [0..w]] in+    runContextT GLFW.defaultHandleConfig $ do+        tex <- newTexture2D SRGB8 size maxBound -- JPG converts to SRGB+        writeTexture2D tex 0 0 size pixels+        return $ texture2DLevels tex+++suite :: IO Benchmark+suite = return $ bgroup "Texture"+    [ bgroup "writeTexture2D"+        [ bench "100x100"   $ whnfIO (benchWriteTexture2D (V2 100 100))+        , bench "1000x1000" $ whnfIO (benchWriteTexture2D (V2 1000 1000))+        ]+    ]
+ bench/bench.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import           Criterion.Main              (defaultMain)++import qualified Graphics.GPipe.BufferBench  as BufferBench+import qualified Graphics.GPipe.TextureBench as TextureBench++main :: IO ()+main = defaultMain =<< sequence+    [ BufferBench.suite+    , TextureBench.suite+    ]
+ src/Graphics/GPipe/Context/GLFW.hs view
@@ -0,0 +1,47 @@+-- | Non interactive applications only need to pass configuration defined here+-- into GPipe's 'runContextT' and 'newWindow'.+--+-- Interactive applications will need "Graphics.GPipe.Context.GLFW.Input".+module Graphics.GPipe.Context.GLFW (+-- * GPipe context handler for GLFW+Handle(),+GLFWWindow(),+-- ** Configuration+-- *** Default configs+defaultHandleConfig,+defaultWindowConfig,+-- *** Custom configs+ContextHandlerParameters(HandleConfig, configErrorCallback, configEventPolicy),+-- | Configuration for the GLFW handle.+--+-- [@'HandleConfig'@] Constructor+--+-- [@'configErrorCallback' ::  'Error' -> String -> IO () @] Specify a callback to handle errors emitted by GLFW.+--+-- [@'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(..),+WindowHint(..),+EventPolicy(..),+-- ** Exceptions+InitException(..),+CreateWindowException(..),+UnsafeWindowHintsException(..),+-- ** Mainthread hooks+mainloop,+mainstep,+-- ** Reexports+module Graphics.GPipe.Context.GLFW.Input,+module Graphics.GPipe.Context.GLFW.Window,+module Graphics.GPipe.Context.GLFW.Misc+) where++-- internal+import           Graphics.GPipe.Context.GLFW.Format+import           Graphics.GPipe.Context.GLFW.Handler+import           Graphics.GPipe.Context.GLFW.Resource+-- reexports+import           Graphics.GPipe.Context.GLFW.Input+import           Graphics.GPipe.Context.GLFW.Misc+import           Graphics.GPipe.Context.GLFW.Window+-- GLFW reexports+import           Graphics.UI.GLFW                     (WindowHint (..))
+ src/Graphics/GPipe/Context/GLFW/Calls.hs view
@@ -0,0 +1,253 @@+-- | 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 qualified Control.Concurrent                 as Conc+import           Control.Monad                      (when)+import           Data.Maybe                         (fromMaybe)+import qualified Text.Printf                        as Text+-- thirdparty+import qualified Graphics.UI.GLFW                   as GLFW+-- local+import           Graphics.GPipe.Context.GLFW.Logger (LogLevel (..), Logger,+                                                     emitLog)++-- 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++-- |+-- * This function may be called from any thread.+getCurrentContext :: IO (Maybe GLFW.Window)+getCurrentContext = GLFW.getCurrentContext++-- |+-- * 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.+say :: Logger -> LogLevel -> String -> IO ()+say logger lvl msg = do+    t <- GLFW.getTime+    tid <- Conc.myThreadId+    c <- getCurrentContext+    emitLog logger lvl $+        Text.printf "[%03.3fs, %s has %s]: %s\n" (fromMaybe (0/0) 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 :: Logger -> String -> Maybe GLFW.Window -> IO ()+makeContextCurrent logger reason windowHuh = do+    ccHuh <- getCurrentContext+    when (ccHuh /= windowHuh) $ do+        emitLog logger 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 = GLFW.swapInterval++-- |+-- * 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 = GLFW.swapBuffers++-- | 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 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.+waitEventsTimeout :: EffectMain -> Double -> IO ()+waitEventsTimeout onMain timeout = onMain $ GLFW.waitEventsTimeout timeout++-- | 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 = GLFW.windowShouldClose++-- |+-- * This function may be called from any thread. Access is not synchronized.+setWindowShouldClose :: GLFW.Window -> Bool -> IO ()+setWindowShouldClose = GLFW.setWindowShouldClose++-- |+-- * This function must only be called from the main thread.+setWindowCloseCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.WindowCloseCallback -> IO ()+setWindowCloseCallback onMain window cb = onMain $ GLFW.setWindowCloseCallback window cb++-- |+-- * 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++-- |+-- * This function must only be called from the main thread.+getWindowSize :: OnMain (Int, Int) -> GLFW.Window -> IO (Int, Int )+getWindowSize onMain window = onMain $ GLFW.getWindowSize window++-- |+-- * This function must only be called from the main thread.+setWindowSizeCallback :: EffectMain -> GLFW.Window -> Maybe GLFW.WindowSizeCallback -> IO ()+setWindowSizeCallback onMain window cb = onMain $ GLFW.setWindowSizeCallback window cb
+ src/Graphics/GPipe/Context/GLFW/Format.hs view
@@ -0,0 +1,51 @@+-- | Internal module for generating and assessing GLFW hint lists+module Graphics.GPipe.Context.GLFW.Format where++-- stdlib+import           Control.Exception (Exception)+-- third party+import qualified Graphics.GPipe    as GPipe+import           Graphics.UI.GLFW  (WindowHint (..))+import qualified Graphics.UI.GLFW  as GLFW++-- | IO Exception thrown when attempting to create a new window using GLFW+-- hints which GPipe manages.+newtype UnsafeWindowHintsException+    = UnsafeWindowHintsException [WindowHint]+    deriving Show+instance Exception UnsafeWindowHintsException++allowedHint :: WindowHint -> Bool+allowedHint (WindowHint'Visible _)             = False+allowedHint (WindowHint'sRGBCapable _)         = 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 4+    , GLFW.WindowHint'ContextVersionMinor 5+    , 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'RedBits $ Just red+    , GLFW.WindowHint'GreenBits $ Just green+    , GLFW.WindowHint'BlueBits $ Just blue+    , GLFW.WindowHint'AlphaBits $ Just alpha+    , GLFW.WindowHint'DepthBits $ Just depth+    , GLFW.WindowHint'StencilBits $ Just stencil+    ]
+ src/Graphics/GPipe/Context/GLFW/Handler.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE TypeFamilies #-}+-- | Internal module defining handler and its ContextHandler instance as well as some methods+module Graphics.GPipe.Context.GLFW.Handler where++-- stdlib+import           Control.Concurrent                   (MVar, ThreadId,+                                                       modifyMVar_, myThreadId,+                                                       newMVar, withMVar)+import           Control.Concurrent.Async             (withAsync)+import           Control.Concurrent.STM               (atomically)+import           Control.Concurrent.STM.TVar          (TVar, modifyTVar,+                                                       newTVarIO, readTVarIO,+                                                       writeTVar)+import           Control.Exception                    (Exception, throwIO)+import           Control.Monad                        (forM, forM_, unless,+                                                       void, when)+import           Control.Monad.IO.Class               (MonadIO, liftIO)+import           Data.List                            (delete, partition)+import           Data.Maybe                           (fromMaybe)+import           Text.Printf                          (printf)+-- thirdparty+import qualified Graphics.GPipe                       as GPipe (ContextHandler (..),+                                                                ContextT,+                                                                Window,+                                                                WindowBits,+                                                                withContextWindow)+import qualified Graphics.UI.GLFW                     as GLFW (Error, Window)+-- 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.Logger   as Log+import qualified Graphics.GPipe.Context.GLFW.RPC      as RPC+import           Graphics.GPipe.Context.GLFW.Resource (defaultWindowConfig)+import qualified Graphics.GPipe.Context.GLFW.Resource as Resource++-- | Internal handle for a GPipe-created GLFW window/context+newtype 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+    , handleRaw         :: GLFW.Window+    , handleCtxs        :: TVar [MMContext]+    , handleEventPolicy :: Maybe EventPolicy+    , handleLogger      :: Log.Logger+    }++-- | 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 = printf "WARNING %s: GPipe-GLFW context already closed" callerTag >> return Nothing+        go (Just context) = pure <$> action context++-- | 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 = printf "WARNING %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.+-- * Log only context handling activity which represents undesired conditions.+defaultHandleConfig :: GPipe.ContextHandlerParameters Handle+defaultHandleConfig = HandleConfig+    { configErrorCallback = printf "%s: %s\n" . show+    , configEventPolicy = pure Poll+    , configLogger = Log.Logger+        { Log.loggerLevel = Log.WARNING+        , Log.loggerSink = Log.stderrSink+        }+    }++instance GPipe.ContextHandler Handle where++    -- | Configuration for the GLFW handle.+    data ContextHandlerParameters Handle = HandleConfig+        { -- | Specify a callback to handle errors emitted by GLFW.+          configErrorCallback :: GLFW.Error -> String -> IO ()+          -- | 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+          -- | Configuration for emitting messages.+        , configLogger :: Log.Logger+        }++    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+        window <- createWindow (handleLogger handle) (Just $ handleRaw handle) settings+        mmContext <- newMVar . pure $ Context window+        atomically $ modifyTVar (handleCtxs handle) (mmContext :)+        return $ WWindow (mmContext, handle)++    -- 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 handle Nothing action = RPC.sendEffect (handleComm handle) $ do+        -- (on main thread) Make the ancestor current if nothing else already is+        -- FIXME: these two bodies could be combined, perhaps.. the RPC is only necessary if the current thread lacks a context+        ccHuh <- Call.getCurrentContext+        maybe (Call.makeContextCurrent (handleLogger handle) "contextDoAsync required some context" . pure $ handleRaw handle)+            (const $ return ())+            ccHuh+        action+    contextDoAsync _ (Just (WWindow (mmContext, handle))) action =+        void $ withContext "contextDoAsync" mmContext $ \context -> do+            Call.makeContextCurrent (handleLogger handle) "contextDoAsync required a specific context" . 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.say (handleLogger handle) Log.ERROR $ 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.say (handleLogger handle) Log.INFO $ printf "contextDelete of %s" (show $ contextRaw <$> mContext)+            forM_ mContext $ \context -> RPC.sendEffect (handleComm handle) $ do+                Call.makeContextCurrent (handleLogger handle) "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.say (configLogger config) Log.DEBUG "contextHandlerCreate"+        -- make handle resources+        tid <- myThreadId+        comm <- RPC.newBound+        ctxs <- newTVarIO []+        -- initialize glfw+        Call.setErrorCallback id . pure $ configErrorCallback config -- 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+        ancestor <- createWindow (configLogger config) Nothing Nothing+        return $ Handle+            { handleTid = tid+            , handleComm = comm+            , handleRaw = ancestor+            , handleCtxs = ctxs+            , handleEventPolicy = configEventPolicy config+            , handleLogger = configLogger config+            }++    -- Threading: main thread+    contextHandlerDelete handle = do+        Call.say (handleLogger handle) Log.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++-- Create a raw GLFW window for use by contextHandlerCreate & createContext+createWindow :: Log.Logger -> Maybe GLFW.Window -> Maybe (GPipe.WindowBits, Resource.WindowConfig) -> IO GLFW.Window+createWindow logger parentHuh settings = do+    unless (null disallowedHints) $+        throwIO $ Format.UnsafeWindowHintsException disallowedHints+    -- make a context+    windowHuh <- Call.createWindow id width height title monitor hints parentHuh -- id RPC because contextHandlerCreate & createContext are called only on mainthread+    Call.say logger Log.DEBUG $ printf "made context %s -> parent %s" (show windowHuh) (show parentHuh)+    window <- maybe exc return windowHuh+    -- set up context+    forM_ intervalHuh $ \interval -> do+        Call.makeContextCurrent logger "apply vsync setting" $ pure window+        Call.swapInterval interval+    -- done+    return window+    where+        config = maybe (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+        exc = throwIO . CreateSharedWindowException . show $ config {Resource.configHints = hints}++-- | 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+    | WaitTimeout Double+    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) $+        throwIO $ MainstepOffMainException "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+        WaitTimeout timeout -> withAsync+                    -- Async sleeps on RPC chan, waking op main when RPC received+                    (RPC.awaitActions (handleComm handle) >> Call.postEmptyEvent)+                    -- Main sleeps on waitEventsTimeout+                    (const $ Call.waitEventsTimeout id timeout) -- 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 Show+instance Exception InitException++-- | IO Exception thrown when GLFW window creation fails.+data CreateWindowException+    = CreateWindowException String+    | CreateSharedWindowException String+    deriving Show+instance Exception CreateWindowException++-- | IO Exception thrown when application code calls a GPipe-GLFW incorrectly+-- (eg. on the wrong thread).+newtype UsageException+    = MainstepOffMainException String+    deriving Show+instance Exception UsageException
+ src/Graphics/GPipe/Context/GLFW/Input.hs view
@@ -0,0 +1,255 @@+-- | User input functions covering much of the GLFW __Input guide__:+-- <http://www.glfw.org/docs/latest/input_guide.html>.+--+-- 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+ --+ --     * `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.++ -- * Keyboard input+ -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#input_keyboard++ -- ** Key input+ setKeyCallback,+ getKey,+ setStickyKeysInputMode,+ getStickyKeysInputMode,++ -- ** Text input+ setCharCallback,++ -- * Mouse input+ -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#input_mouse++ -- ** Cursor position+ setCursorPosCallback,+ getCursorPos,++ -- ** Cursor modes+ setCursorInputMode,+ getCursorInputMode,++ -- ** Cursor objects++ -- *** Custom cursor creation+ GLFW.createCursor,++ -- *** Standard cursor creation+ GLFW.createStandardCursor,++ -- *** Cursor destruction+ GLFW.destroyCursor,++ -- *** Cursor setting+ setCursor,++ -- ** Cursor enter/leave events+ setCursorEnterCallback,++ -- ** Mouse button input+ setMouseButtonCallback,+ getMouseButton,+ setStickyMouseButtonsInputMode,+ getStickyMouseButtonsInputMode,++ -- ** Scroll input+ setScrollCallback,++ -- * Joystick input+ -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#joystick+ GLFW.joystickPresent,+ -- | Is the specified 'Joystick' currently connected?++ -- ** Joystick axis states+ GLFW.getJoystickAxes,+ -- | Poll for the positions of each axis on the 'Joystick'. Positions are on the range `-1.0..1.0`.++ -- ** Joystick button states+ GLFW.getJoystickButtons,+ -- | Poll for the 'JoystickButtonState' of each button on the 'Joystick'.++ -- ** Joystick name+ GLFW.getJoystickName,+ -- | Retrieve a non-unique string identifier for the 'Joystick'.+ -- This might be the make & model name of the device.++ -- * Time input+ -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#time+ GLFW.getTime,+ -- | Poll for the number of seconds since GLFW was initialized by GPipe.+ GLFW.setTime,+ -- | Manually set the timer to a specified value.++ -- * Clipboard input and output+ -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#clipboard+ getClipboardString,+ setClipboardString,++ -- * Path drop input+ -- | Learn more: http://www.glfw.org/docs/latest/input_guide.html#path_drop+ setDropCallback,++ -- * Reexported datatypes++ -- ** Keyboard+ Key(..),+ KeyState(..),+ ModifierKeys(..),+ StickyKeysInputMode(..),++ -- ** Mouse+ CursorInputMode(..),+ StandardCursorShape(..),+ CursorState(..),+ StickyMouseButtonsInputMode(..),+ MouseButton(..),+ MouseButtonState(..),++ -- ** Joystick+ Joystick(..),+ JoystickButtonState(..),++ -- * Not supported+ -- | Some GLFW functionality isn't currently exposed by "Graphics.UI.GLFW".+ --+ --     * `glfwWaitEventsTimeout`+ --     * `glfwSetCharModsCallback`+ --     * `glfwGetKeyName`+ --     * `glfwSetJoystickCallback`+ --     * `glfwGetTimerValue`+ --     * `glfwGetTimerFrequency`+ ) where++-- stdlib+import           Control.Monad.IO.Class               (MonadIO)+import qualified Graphics.GPipe.Context               as GPipe (ContextT,+                                                                Window)+-- third party+import           Graphics.UI.GLFW                     (Cursor (..),+                                                       CursorInputMode (..),+                                                       CursorState (..),+                                                       Joystick (..),+                                                       JoystickButtonState (..),+                                                       Key (..), KeyState (..),+                                                       ModifierKeys (..),+                                                       MouseButton (..),+                                                       MouseButtonState (..),+                                                       StandardCursorShape (..),+                                                       StickyKeysInputMode (..),+                                                       StickyMouseButtonsInputMode (..))+import qualified Graphics.UI.GLFW                     as GLFW+-- local+import qualified Graphics.GPipe.Context.GLFW.Calls    as Call+import           Graphics.GPipe.Context.GLFW.Handler  (Handle (..))+import           Graphics.GPipe.Context.GLFW.Wrappers (withWindowRPC,+                                                       wrapCallbackSetter,+                                                       wrapWindowFun)++++{- Keyboard -}++-- | Register or unregister a callback to receive 'KeyState' changes to any 'Key'.+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 => 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 => GPipe.Window os c ds -> StickyKeysInputMode -> GPipe.ContextT Handle os m (Maybe ())+setStickyKeysInputMode = wrapWindowFun Call.setStickyKeysInputMode++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 => 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 => 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 => 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 => GPipe.Window os c ds -> CursorInputMode -> GPipe.ContextT Handle os m (Maybe ())+setCursorInputMode = wrapWindowFun Call.setCursorInputMode++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 => 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 => 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 => 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 => 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 => GPipe.Window os c ds -> StickyMouseButtonsInputMode -> GPipe.ContextT Handle os m (Maybe ())+setStickyMouseButtonsInputMode = wrapWindowFun Call.setStickyMouseButtonsInputMode++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 => GPipe.Window os c ds -> Maybe (Double -> Double -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setScrollCallback = wrapCallbackSetter Call.setScrollCallback++{- Joystick -}++{- Time -}++{- Clipboard -}++-- | Poll the system clipboard for a UTF-8 encoded string, if one can be extracted.+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 => 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 => GPipe.Window os c ds -> Maybe ([String] -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setDropCallback = wrapCallbackSetter Call.setDropCallback
+ src/Graphics/GPipe/Context/GLFW/Logger.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE NamedFieldPuns #-}+module Graphics.GPipe.Context.GLFW.Logger where++import           System.IO   (hPutStrLn, stderr)+import           Text.Printf (printf)++-- | Levels of severity for log messages.+data LogLevel = DEBUG | INFO | WARNING | ERROR+    deriving (Show, Eq, Ord, Enum, Bounded)++-- | An arbitrary sink into which log messages may be passed.+newtype LogSink = LogSink { runSink :: String -> IO () }++-- | Very simple logger handle.+data Logger = Logger+    { loggerLevel :: LogLevel+    , loggerSink  :: LogSink+    }++-- | Emit a message to the sink specified by 'Logger' if the provided+-- 'Loglevel' is more severe than the configured one.+emitLog :: Logger -> LogLevel -> String -> IO ()+emitLog Logger{loggerLevel, loggerSink} messageLevel message+    | loggerLevel <= messageLevel = runSink loggerSink $ printf "%s %s" (show messageLevel) message+    | otherwise = return ()++-- | A 'LogSink' which writes to the @stderr@ stream.+stderrSink :: LogSink+stderrSink = LogSink $ hPutStrLn stderr
+ src/Graphics/GPipe/Context/GLFW/Misc.hs view
@@ -0,0 +1,15 @@+-- | Miscellaneous wrapped calls to GLFW-b for application programmer use.+--+-- 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.Misc (+-- * Error handling+-- | Learn more: http://www.glfw.org/docs/latest/intro_guide.html#error_handling++-- | To set a custom error callback use 'HandleConfig' in "Graphics.GPipe.Context.GLFW".+Error(..),+) where++-- thirdparty+import           Graphics.UI.GLFW (Error (..))
+ src/Graphics/GPipe/Context/GLFW/RPC.hs view
@@ -0,0 +1,70 @@+module Graphics.GPipe.Context.GLFW.RPC where++-- stdlib+import           Control.Concurrent            (ThreadId, myThreadId)+import           Control.Concurrent.MVar       (newEmptyMVar, putMVar, takeMVar)+import           Control.Concurrent.STM        (STM, atomically)+import           Control.Concurrent.STM.TQueue (TQueue, newTQueue, peekTQueue,+                                                tryReadTQueue, writeTQueue)+import           Data.Sequence                 (Seq, empty, (|>))+-- 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 = mapM_ go+    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
+ src/Graphics/GPipe/Context/GLFW/Resource.hs view
@@ -0,0 +1,21 @@+-- | Internal module defining resources and associated types+module Graphics.GPipe.Context.GLFW.Resource where++-- thirdparty+import qualified Graphics.UI.GLFW as GLFW (Monitor, WindowHint)++-- | 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+    )++-- | 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
+ src/Graphics/GPipe/Context/GLFW/Window.hs view
@@ -0,0 +1,69 @@+-- | Window manipulation functions covering much of the GLFW __Window guide__:+-- <http://www.glfw.org/docs/latest/window_guide.html>.+-- Notably absent are the window creation functions. These are handled automatically by GPipe-GLFW.+--+-- 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.Window (+-- * Window objects+-- | Learn more: http://www.glfw.org/docs/latest/window_guide.html#window_object++-- * Window event processing+-- | GLFW event processing is performed by 'GPipe-GLFW' after each call to the 'GPipe' @swapBuffers@.+-- No further action is required, but additional controls are available for complex applications in+-- "Graphics.GPipe.Context.GLFW".++-- * Window properties and events+-- | Learn more: http://www.glfw.org/docs/latest/window_guide.html#window_properties++-- ** Window closing and close flag+windowShouldClose,+setWindowShouldClose,+setWindowCloseCallback,++-- ** Window size+getWindowSize,+setWindowSizeCallback,++-- ** Framebuffer size+-- | Reexported from "Graphics.GPipe.Context".+GPipe.getFrameBufferSize,++-- * Buffer swapping+-- | Buffer swapping is initiated via the 'GPipe' @swapBuffers@ function.++-- * Not supported+-- | Some GLFW functionality isn't currently exposed by "Graphics.UI.GLFW".+--+--      * `glfwSetWindowUserPointer`, `glfwGetWindowUserPointer`+) where++-- stdlib+import           Control.Monad.IO.Class               (MonadIO)+--thirdparty+import qualified Graphics.GPipe.Context               as GPipe (ContextT,+                                                                Window,+                                                                getFrameBufferSize)+--local+import qualified Graphics.GPipe.Context.GLFW.Calls    as Call+import           Graphics.GPipe.Context.GLFW.Handler  (Handle (..))+import qualified Graphics.GPipe.Context.GLFW.Wrappers as Wrappers++-- TODO: function docstrings++getWindowSize :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe (Int, Int))+getWindowSize = Wrappers.withWindowRPC Call.getWindowSize++setWindowSizeCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (Int -> Int -> IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setWindowSizeCallback = Wrappers.wrapCallbackSetter Call.setWindowSizeCallback++windowShouldClose :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe Bool)+windowShouldClose = Wrappers.withWindow Call.windowShouldClose++setWindowShouldClose :: MonadIO m => GPipe.Window os c ds -> Bool -> GPipe.ContextT Handle os m (Maybe ())+setWindowShouldClose w b = Wrappers.withWindow (`Call.setWindowShouldClose` b) w++setWindowCloseCallback :: MonadIO m => GPipe.Window os c ds -> Maybe (IO ()) -> GPipe.ContextT Handle os m (Maybe ())+setWindowCloseCallback = Wrappers.wrapCallbackSetter Call.setWindowCloseCallback
+ src/Graphics/GPipe/Context/GLFW/Wrappers.hs view
@@ -0,0 +1,33 @@+-- | 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.GPipe.Context              as GPipe (ContextT, Window)+import qualified Graphics.UI.GLFW                    as GLFW+-- local+import qualified Graphics.GPipe.Context.GLFW.Calls   as Call+import qualified Graphics.GPipe.Context.GLFW.Handler as Handler+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)
+ test/Graphics/GPipe/BufferSpec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+module Graphics.GPipe.BufferSpec where++import           Test.Hspec                  (Spec, describe, it, shouldBe)++import           Graphics.GPipe.Buffer++import           Graphics.GPipe.Context      (runContextT)+import qualified Graphics.GPipe.Context.GLFW as GLFW+++spec :: Spec+spec = do+  describe "bufferLength" $ do+    it "should return the initial size of the buffer" $ do+      l <- runContextT GLFW.defaultHandleConfig $ do+        buf :: Buffer os (B Float) <- newBuffer 100000+        writeBuffer buf 0 [0..50000]+        return $ bufferLength buf+      l `shouldBe` 100000
+ test/Graphics/GPipe/Context/GLFW/CloseSpec.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+module Graphics.GPipe.Context.GLFW.CloseSpec (spec) where++import           Test.Hspec                  (Spec, describe, it)++import           Control.Monad               (when)+import           Control.Monad.IO.Class      (liftIO)+import           Data.Functor                (void)+import           Data.Maybe                  (fromMaybe)+import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common                 as C+import qualified Test.Control                as A++spec :: Spec+spec = do+    describe "Window-should-close interfaces" $ do+        it "should render a scene using additional additional GLFW interfaces" $ do+            C.runContext handleConfig $ do+                win <- newWindow (WindowFormatColorDepth RGB8 Depth16) (GLFW.defaultWindowConfig "Window-should-close")+                void $ GLFW.setWindowCloseCallback win $ Just onCloseButton+                resources <- C.initRenderContext win [C.xAxis, C.yAxis, C.zAxis]+                C.mainloop win (A.repeat $ A.seconds 1.0) resources $ \controller -> do+                    Just t <- liftIO $ GLFW.getTime+                    when (t > 3.5) $ do+                        liftIO $ putStrLn "!! Programmatically setting window-close bit"+                        Just () <- GLFW.setWindowShouldClose win True+                        return ()+                    shouldClose <- GLFW.windowShouldClose win+                    return $ fromMaybe False shouldClose+            where+                onCloseButton = putStrLn "!! Window-close button pressed"+                handleConfig = GLFW.defaultHandleConfig {GLFW.configErrorCallback=curry print :: GLFW.Error -> String -> IO ()}
+ test/Graphics/GPipe/Context/GLFW/FixedSpec.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+module Graphics.GPipe.Context.GLFW.FixedSpec (spec) where++import           Test.Hspec                  (Spec, describe, it)++import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common                 as C+import qualified Test.Control                as A++spec :: Spec+spec = do+    describe "Fixed frame count" $ do+        it ("should render a scene to a window for " ++ show maxFrames ++ " frames") $ do+            C.runContext GLFW.defaultHandleConfig $ do+                win <- newWindow (WindowFormatColorDepth RGB8 Depth16) (GLFW.defaultWindowConfig "Fixed")+                resources <- C.initRenderContext win [C.xAxis, C.yAxis, C.zAxis, C.plane]+                C.mainloop win (A.frames maxFrames) resources C.continue+            where+                maxFrames = 60
+ test/Graphics/GPipe/Context/GLFW/InputSpec.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+module Graphics.GPipe.Context.GLFW.InputSpec (spec) where++import           Test.Hspec                        (Spec, describe, it)++import           Data.Functor                      (void)+import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW       as GLFW+import qualified Graphics.GPipe.Context.GLFW.Input as Input+import qualified Test.Common                       as C+import qualified Test.Control                      as A+import           Text.Printf                       (printf)++spec :: Spec+spec = do+    describe "Input" $ do+        it "should listen for button inputs while rendering a scene to a window" $ do+            C.runContext GLFW.defaultHandleConfig $ do+                win <- newWindow (WindowFormatColorDepth RGB8 Depth16) (GLFW.defaultWindowConfig "Input")++                void $ Input.setCursorPosCallback win $ Just (printf "Cursor pos: %fx%f\n")+                void $ Input.setMouseButtonCallback win $ Just (\b s m -> printf "Mouse: %s %s\n" (show b) (show s))+                void $ Input.setKeyCallback win $ Just (\k i s m -> printf "Key: %s %s %s\n" (show k) (show i) (show s))++                resources <- C.initRenderContext win [C.plane, C.yAxis]+                C.mainloop win (A.frames 120) resources C.continue
+ test/Graphics/GPipe/Context/GLFW/ManualSpec.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+module Graphics.GPipe.Context.GLFW.ManualSpec (spec) where++import           Test.Hspec                  (Spec, describe, it)++import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common                 as C+import qualified Test.Control                as A++spec :: Spec+spec = do+    describe "Manual event processing" $ do+        it "should render a scene to a window without automatic event processing" $ do+            C.runContext handleConfig $ do+                win <- newWindow (WindowFormatColorDepth RGB8 Depth16) (GLFW.defaultWindowConfig "Manual")+                resources <- C.initRenderContext win [C.xAxis, C.yAxis, C.zAxis]+                C.mainloop win (A.frames 60) resources (const $ GLFW.mainstep win GLFW.Poll >> C.continue undefined)+            where+                -- Config which disables automatic event processing+                handleConfig = GLFW.defaultHandleConfig {GLFW.configEventPolicy=Nothing}
+ test/Graphics/GPipe/Context/GLFW/MultiPassSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+module Graphics.GPipe.Context.GLFW.MultiPassSpec (spec) where++import           Test.Hspec                  (Spec, describe, it)++import           Control.Lens                ((^.))+import           Control.Monad               (unless)+import           Control.Monad.IO.Class      (liftIO)+import           Data.Word                   (Word32)+import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common                 as C++spec :: Spec+spec = do+    describe "Multi-pass render" $ do+        it "should render a quad with another rendering on it" $ do+            C.runContext GLFW.defaultHandleConfig $ do+                win <- newWindow (WindowFormatColor RGB8) (GLFW.defaultWindowConfig "Checkers")+                vertexBuffer :: Buffer os (B2 Float) <- newBuffer 4+                writeBuffer vertexBuffer 0 [V2 0 0, V2 1 0, V2 0 1, V2 1 1]+                tex <- newTexture2D R8 (V2 8 8) 1+                let whiteBlack = cycle [minBound,maxBound] :: [Word32]+                    blackWhite = tail whiteBlack+                writeTexture2D tex 0 0 (V2 8 8) (cycle (take 8 whiteBlack ++ take 8 blackWhite))++                colorTex <- newTexture2D RG8 (V2 256 256) 1+                depthTex <- newTexture2D Depth16 (V2 256 256) 1++                shader1 <- compileShader $ do+                  texMappedFragmentStream <- getProjectedFragments 256 (V3 0.5 (-0.8) (-0.8)) (V3 0.5 0.5 0) (V3 0 1 0)  textureMappedPrimitives+                  solidFragmentStream <- getProjectedFragments 256 (V3 (-0.6) (-0.6) 0.8) (V3 0.25 0.25 0) (V3 0 1 0) solidPrimitives+                  let filterMode = SamplerFilter Nearest Nearest Nearest Nothing+                      edge = (pure ClampToEdge, 0)+                  samp <- newSampler2D (const (tex, filterMode, edge))+                  let sampleTexture = sample2D samp SampleAuto Nothing Nothing+                      texMappedFragmentStream2 = filterFragments ((>* 0.5) . sampleTexture) texMappedFragmentStream+                      texMappedFragmentStream3 = fmap (const (V2 1 0)) texMappedFragmentStream2+                      solidFragmentStream2 = fmap (const (V2 0 1)) solidFragmentStream+                      fragmentStream = solidFragmentStream2 `mappend` texMappedFragmentStream3+                      fragmentStream2 = withRasterizedInfo (\a r -> (a, rasterizedFragCoord r ^. _z)) fragmentStream+                  drawDepth (\s -> (NoBlending, depthImage s, DepthOption Less True)) fragmentStream2 $ \ a -> do+                    drawColor (\ s -> (colorImage s, pure True, False)) a++                shader2 <- compileShader $ do+                  fragmentStream <- getProjectedFragments 800 (V3 1 2 2) (V3 0.5 0.5 0) (V3 0 1 0) id++                  let filterMode = SamplerFilter Linear Linear Nearest Nothing+                      edge = (pure ClampToEdge, 0)+                  samp <- newSampler2D (const (colorTex, filterMode, edge))+                  let sampleTexture = sample2D samp SampleAuto Nothing Nothing+                      fragmentStream2 = fmap ((\(V2 r g) -> V3 r 0 g) . sampleTexture) fragmentStream+                  drawWindowColor (const (win, ContextColorOption NoBlending (pure True))) fragmentStream2++                Just start <- liftIO GLFW.getTime+                renderLoop start win [+                  do+                    vertexArray <- newVertexArray vertexBuffer+                    let singleTriangle = takeVertices 3 vertexArray+                    cImage <- getTexture2DImage colorTex 0+                    dImage <- getTexture2DImage depthTex 0+                    clearImageColor cImage 0+                    clearImageDepth dImage 1+                    shader1 $ ShaderEnvironment+                        (toPrimitiveArray TriangleStrip vertexArray)+                        (toPrimitiveArray TriangleList singleTriangle)+                        cImage+                        dImage+                  ,+                  do+                    clearWindowColor win 0.5+                    vertexArray <- newVertexArray vertexBuffer+                    shader2 (toPrimitiveArray TriangleStrip vertexArray)+                  ]++getProjectedFragments size eye center up sf = do+  primitiveStream <- toPrimitiveStream sf+  let primitiveStream2 = fmap (\pos2d -> (make3d eye center up pos2d, pos2d)) primitiveStream+  rasterize (const (FrontAndBack, PolygonFill, ViewPort (V2 0 0) (V2 size size), DepthRange 0 1)) primitiveStream2++make3d :: Floating a => V3 a -> V3 a -> V3 a -> V2 a -> V4 a+make3d eye center up (V2 x y) = projMat !*! viewMat !* V4 x y 0 1+  where+    viewMat = lookAt eye center up+    projMat = perspective (pi/3) 1 1 100++renderLoop :: Double -> Window os c ds -> [Render os ()] -> ContextT GLFW.Handle os IO ()+renderLoop start win renderings = do+  mapM_ render renderings+  swapWindowBuffers win+  closeRequested <- GLFW.windowShouldClose win+  Just now <- liftIO GLFW.getTime+  unless (now - start > 1 || closeRequested == Just True) $+    renderLoop start win renderings+++data ShaderEnvironment = ShaderEnvironment+  {+    textureMappedPrimitives, solidPrimitives  :: PrimitiveArray Triangles (B2 Float),+    colorImage :: Image (Format RGFloat),+    depthImage :: Image (Format Depth)+  }
+ test/Graphics/GPipe/Context/GLFW/SequenceSpec.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+module Graphics.GPipe.Context.GLFW.SequenceSpec (spec) where++import           Test.Hspec                  (Spec, describe, it)++import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common                 as C+import qualified Test.Control                as A++spec :: Spec+spec = do+    describe "Multiple sequential windows" $ do+        it "should render a scene on a window and then render again on a second window" $ do+            C.runContext GLFW.defaultHandleConfig $ do++                first <- newWindow (WindowFormatColorDepth SRGB8 Depth16) (GLFW.defaultWindowConfig "Sequence 1 (of 2)")+                resources <- C.initRenderContext first [C.yAxis]+                C.mainloop first (A.frames 30) resources C.continue+                deleteWindow first++                second <- newWindow (WindowFormatColorDepth SRGB8 Depth16) (GLFW.defaultWindowConfig "Sequence 2 (of 2)")+                C.mainloop second (A.frames 30) resources C.continue+                deleteWindow second
+ test/Graphics/GPipe/Context/GLFW/TimedSpec.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}+module Graphics.GPipe.Context.GLFW.TimedSpec (spec) where++import           Test.Hspec                  (Spec, describe, it)++import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified Test.Common                 as C+import qualified Test.Control                as A++spec :: Spec+spec = do+    describe "Timed render" $ do+        it ("should render a scene to a window for " ++ show maxSec ++ " seconds") $ do+            C.runContext GLFW.defaultHandleConfig $ do+                win <- newWindow (WindowFormatColorDepth RGB8 Depth16) (GLFW.defaultWindowConfig "Timed")+                resources <- C.initRenderContext win [C.xAxis, C.yAxis, C.zAxis, C.plane]+                C.mainloop win (A.seconds maxSec) resources C.continue+            where+                maxSec = 2.0
+ test/Graphics/GPipe/GeometryStream/IdentitySpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+module Graphics.GPipe.GeometryStream.IdentitySpec (spec) where++import           Test.Hspec      (Spec, it)++import           Control.Lens    ((^.))+import           Data.Function   ((&))+import           Graphics.GPipe+import           Test.ShaderTest (Shaders (Shaders))+import qualified Test.ShaderTest as S++type ShaderAttachment a = V3 a++--------------------------------------------------++topology :: Triangles+topology = TriangleList++vertices :: [(V3 Float, V3 Float, V3 Float)]+vertices =+  [ (V3 (-1) 1 0, 0, V3 1 0 0)+  , (V3 0 (-1) 0, 0, V3 0 1 0)+  , (V3 1 1 0, 0, V3 0 0 1)+  ]++--------------------------------------------------++vert+  :: (V3 VFloat, V3 VFloat, V3 VFloat)+  -> (VPos, ShaderAttachment VFloat)+vert (pos, _n, clr) = (point $ pos^._xyz / 2 - 0.25, clr / 10)++--------------------------------------------------++maxVertices :: Int+maxVertices = 3++geom+  :: GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+  -> Geometry Triangles (VPos, ShaderAttachment VFloat)+  -> GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+geom g (Triangle p1 p2 p3) = g+  & emitVertexPosition p1+  & emitVertexPosition p2+  & emitVertexPosition p3++  & endPrimitive++--------------------------------------------------++frag+  :: ShaderAttachment FFloat+  -> V3 FFloat+frag clr = clr++--------------------------------------------------++spec :: Spec+spec = do+  it "should show the input with an identity shader" $ do+    S.main Shaders{topology, vertices, vert, maxVertices, geom, frag}
+ test/Graphics/GPipe/GeometryStream/Shader2DSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+module Graphics.GPipe.GeometryStream.Shader2DSpec (spec) where++import           Test.Hspec      (Spec, it)++import           Control.Lens    ((^.))+import           Data.Function   ((&))+import           Graphics.GPipe+import           Test.ShaderTest (Shaders (Shaders))+import qualified Test.ShaderTest as S++type ShaderAttachment a = V3 a++--------------------------------------------------++topology :: Triangles+topology = TriangleList++vertices :: [(V3 Float, V3 Float, V3 Float)]+vertices =+  [ (V3 (-1) 1 0, 0, V3 1 0 0)+  , (V3 0 (-1) 0, 0, V3 0 1 0)+  , (V3 1 1 0, 0, V3 0 0 1)+  ]++--------------------------------------------------++vert+  :: (V3 VFloat, V3 VFloat, V3 VFloat)+  -> (VPos, ShaderAttachment VFloat)+vert (pos, _n, clr) = (point $ pos^._xyz / 2 - 0.25, clr / 10)++--------------------------------------------------++maxVertices :: Int+maxVertices = 6++geom+  :: GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+  -> Geometry Triangles (VPos, ShaderAttachment VFloat)+  -> GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+geom g (Triangle p1 p2 p3) = g+  & emitVertexPosition p1+  & emitVertexPosition p2+  & emitVertexPosition p3++  & emitVertexPosition (fst p1 + V4 1.0 0.5 0 0, snd p1 * 10)+  & emitVertexPosition (fst p1 + V4 0.5 0.5 0 0, snd p2 * 10)+  & emitVertexPosition (fst p1 + V4 0.5 0.5 0 0, snd p3 * 10)++  & endPrimitive++--------------------------------------------------++frag+  :: ShaderAttachment FFloat+  -> V3 FFloat+frag clr = clr++--------------------------------------------------++spec :: Spec+spec = do+  it "should show multiple colourful triangles" $ do+    S.main Shaders{topology, vertices, vert, maxVertices, geom, frag}
+ test/Graphics/GPipe/GeometryStream/Shader3DSpec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE Arrows          #-}+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+module Graphics.GPipe.GeometryStream.Shader3DSpec (spec) where++import           Test.Hspec      (Spec, it)++import           Control.Arrow   (returnA)+import           Data.Function   ((&))+import           Graphics.GPipe+import           Test.ShaderTest (Shaders (Shaders))+import qualified Test.ShaderTest as S++import           Control.Arrow   (returnA)+import           Control.Lens    ((^.))+import           Data.Function   ((&))+import           Graphics.GPipe+import           Test.ShaderTest (Shaders (Shaders))+import qualified Test.ShaderTest as S++data ShaderAttachment a = ShaderAttachment+  { color  :: V3 a+  , normal :: V3 a+  }++instance FragmentInput a => FragmentInput (ShaderAttachment a) where+  type FragmentFormat (ShaderAttachment a) = ShaderAttachment (FragmentFormat a)+  toFragment = proc ~(ShaderAttachment a b) -> do+    a' <- toFragment -< a+    b' <- toFragment -< b+    returnA -< ShaderAttachment a' b'++instance FragmentCreator a => FragmentCreator (ShaderAttachment a) where+  createFragment = ShaderAttachment+    <$> createFragment+    <*> createFragment++instance AnotherVertexInput a => AnotherVertexInput (ShaderAttachment a) where+  toAnotherVertex = proc ~(ShaderAttachment a b) -> do+    a' <- toAnotherVertex -< a+    b' <- toAnotherVertex -< b+    returnA -< ShaderAttachment a' b'++instance AnotherFragmentInput a => AnotherFragmentInput (ShaderAttachment a) where+  toFragment2 = proc ~(ShaderAttachment a b) -> do+    a' <- toFragment2 -< a+    b' <- toFragment2 -< b+    returnA -< ShaderAttachment a' b'++instance GeometryExplosive a => GeometryExplosive (ShaderAttachment a) where+    exploseGeometry (ShaderAttachment a b) n = exploseGeometry (a, b) n+    declareGeometry ~(ShaderAttachment a b) = declareGeometry (a, b)+    enumerateVaryings ~(ShaderAttachment a b) = enumerateVaryings (a, b)++--------------------------------------------------++topology :: Points+topology = PointList++vertices :: [(V3 Float, V3 Float, V3 Float)]+vertices =+  [ (V3 (x / 5) (y / 5) 0, V3 0 0 1, V3 0.5 1 0.5)+  | x <- [-5..5], y <- [-5..5]+  ]++--------------------------------------------------++viewMat, projMat, projection :: M44 VFloat+viewMat = lookAt (V3 2 2 1) (V3 0 0 0) (V3 0 0 1)+projMat = perspective (pi/3) 1 1 100+projection = projMat !*! viewMat++vert+  :: (V3 VFloat, V3 VFloat, V3 VFloat)+  -> (VPos, ShaderAttachment VFloat)+vert (pos, normal, clr) = (fragPos, sa)+  where+    fragPos = projection !* point pos++    normalMat = transpose (inv44 viewMat)+    sa = ShaderAttachment{color=clr / 10, normal=(normalMat !* point normal) ^. _xyz}++--------------------------------------------------++maxVertices :: Int+maxVertices = 5++geom+  :: GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+  -> Geometry Points (VPos, ShaderAttachment VFloat)+  -> GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+geom g (Point (pos, sa@ShaderAttachment{..})) = g+  & emit (V4 (-0.05) (-0.1) 0 0) color+  & emit (V4   0.05  (-0.1) 0 0) color+  & emit (V4 (-0.05)   0.1  0 0) (color * 2)+  & emit (V4   0.05    0.1  0 0) (color * 2)+  & emit (V4   0.00    0.2  0 0) (color * 2.5)++  & endPrimitive+  where+    emit p c = emitVertexPosition ((pos + p), sa{color=c})++--------------------------------------------------++frag+  :: ShaderAttachment FFloat+  -> V3 FFloat+frag ShaderAttachment{..} = color + normal*0++--------------------------------------------------++spec :: Spec+spec = do+  it "should show many identical houses" $ do+    S.main Shaders{topology, vertices, vert, maxVertices, geom, frag}
+ test/Test/Common.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types       #-}+{-# LANGUAGE TypeFamilies     #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Test.Common where++import           Control.Monad.IO.Class      (liftIO)+import           Data.Traversable            (forM)+import           GHC.Float                   (double2Float)+import qualified System.Environment          as Env++import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW (getTime)+import           Test.Control                (Controller (..))++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)]++data ShaderEnv os = ShaderEnv+    { extractProjU    :: (Buffer os (Uniform (V4 (B4 Float))), Int)+    , extractLinePA   :: PrimitiveArray Lines (B3 Float, B3 Float)+    , extractRastOpts :: (Side, PolygonMode, ViewPort, DepthRange)+    }++initBuffers win 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 :: Shader os (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++checkEnv :: IO ()+checkEnv = do+    val <- Env.lookupEnv "LIBGL_ALWAYS_SOFTWARE"+    let warn = case val of+            Nothing -> " !! If you don't have hardware support, expect a crash."+            _       -> ""+    putStrLn $ "LIBGL_ALWAYS_SOFTWARE: " ++ show val ++ warn++-- XXX: just adds the draw call to the end of the shader & glues some init functions together+initRenderContext win rawMeshes  = do+    liftIO checkEnv+    projShader <- compileShader (projectLines >>= drawWindowColorDepth (const (win, ContextColorOption NoBlending $ pure True, DepthOption Less True)))+    (meshesB, projMatB) <- initBuffers win 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++renderStep+    :: Window os RGBFloat Depth+    -> V2 Int+    -> ( [Buffer os (B3 Float, B3 Float)]+       , Buffer os (Uniform (V4 (B4 Float)))+       , CompiledShader os (ShaderEnv os)+       )+    -> Render os ()+renderStep win size (meshesB, projMatB, projShader) = do+    clearWindowColor win 0.2 -- grey+    clearWindowDepth win 1 -- far plane+    meshPAs <- forM meshesB $ \mesh -> do+        meshVA <- newVertexArray mesh+        return $ toPrimitiveArray LineStrip meshVA+    projShader $ ShaderEnv (projMatB, 0) (mconcat meshPAs) (Front, PolygonFill, ViewPort 0 size, DepthRange 0 1)++runContext :: (ContextHandler ctx) => ContextHandlerParameters ctx -> (forall os. ContextT ctx os IO a) -> IO a+runContext = runContextT++continue :: Monad m => a -> m Bool+continue _ = return False++mainloop win controller resources@(_, projMatB, _) hook = do+    stop <- hook controller+    Just now <- liftIO GLFW.getTime+    if done now controller || stop+    then return ()+    else do+        -- compute a projection matrix & write it to the buffer+        size <- getFrameBufferSize win+        writeBuffer projMatB 0 [computeProjMat (double2Float $ frac now controller) size]+        -- render the scene and then loop+        render $ renderStep win size resources+        swapWindowBuffers win+        mainloop win (next now controller) resources hook
+ test/Test/Control.hs view
@@ -0,0 +1,43 @@+module Test.Control where++import           Prelude hiding (repeat)++-- | Functions to control animation progress and completion. First argument is the result of GLFW.getTime.+class Controller c where+    -- | Are we done yet?+    done :: Double -> c -> Bool+    done now c = frac now c >= 1.0++    -- | What fraction of completion have we reached?+    frac :: Double -> c -> Double++    -- | Advance to the next frame.+    next :: Double -> c -> c++-- | Render a fixed number of frames. Ignore time.+newtype Fixed = Fixed (Int, Int) deriving Show+instance Controller Fixed where+    frac _ (Fixed (max, count)) = fromIntegral count / fromIntegral max+    next _ (Fixed tup) = Fixed $ fmap (+1) tup+frames :: Int -> Fixed+frames max = Fixed (max, 0) -- (frame count, current frame)++-- | Render for a time period.+newtype Timed = Timed (Double, Double) deriving Show+instance Controller Timed where+    frac now (Timed (dur, s)) = let start = if s < 0 then now else s+        in (now - start) / dur+    next now f@(Timed (dur, s)) = if s < 0 then Timed (dur, now) else f+seconds :: Double -> Timed+seconds duration = Timed (duration, -1) -- start time is <0 until first call to next++-- | Render another Controller forever.+newtype Repeat a = Repeat (a, Int, a) deriving Show+instance Controller a => Controller (Repeat a) where+    frac now (Repeat (begin, _, c)) = if done now c then frac now begin else frac now c+    next now (Repeat (begin, count, c)) = let nc = next now c+        in if done now nc then Repeat (begin, count + 1, begin) else Repeat (begin, count, nc)+repeat :: a -> Repeat a+repeat controller = Repeat (controller, 0, controller)++-- | Render another Controller a fixed set of times.
+ test/Test/ShaderTest.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+module Test.ShaderTest (main, Shaders (..)) where++import           Control.Exception           (handle)+import           Control.Lens                ((^.))+import           Control.Monad               (unless)+import           Control.Monad.IO.Class      (liftIO)+import           Graphics.GPipe+import qualified Graphics.GPipe.Context.GLFW as GLFW+import qualified System.Environment          as Env+import           System.Exit                 (exitFailure)++windowSize :: V2 Int+windowSize = V2 1000 1000++data Shaders sa topology = Shaders+  { topology :: topology+  , vertices :: [(V3 Float, V3 Float, V3 Float)]+  , vert :: (V3 VFloat, V3 VFloat, V3 VFloat) -> (VPos, sa VFloat)+  , maxVertices :: Int+  , geom :: GGenerativeGeometry Triangles (VPos, sa VFloat) -> Geometry topology (VPos, sa VFloat) -> GGenerativeGeometry Triangles (VPos, sa VFloat)+  , frag :: FragmentFormat (sa VFloat) -> V3 FFloat+  }++main+  :: ( FragmentInput (sa VFloat)+     , AnotherVertexInput (sa VFloat)+     , FragmentCreator (sa VFloat)+     , PrimitiveTopology topology+     , GeometryInput topology (VPos, sa VFloat)+     )+  => Shaders sa topology+  -> IO ()+main Shaders{..} = do+  handle handler $ runContextT GLFW.defaultHandleConfig $ do+    win <- newWindow (WindowFormatColor RGB8) (GLFW.defaultWindowConfig "Geometry shader test")+      { GLFW.configWidth = windowSize^._x+      , GLFW.configHeight = windowSize^._y+      }+    vertexBuffer <- newBuffer $ length vertices+    writeBuffer vertexBuffer 0 vertices++    shader <- compileShader $ do+      primitiveStream <- fmap vert+        <$> toPrimitiveStream id++      expandedGeometries <-+          fmap (geom generativeTriangleStrip)+              <$> geometrize primitiveStream++      fragmentStream <- fmap frag+        -- <$> rasterize (const (Front, PolygonFill, ViewPort (V2 0 0) windowSize, DepthRange 0 1)) primitiveStream+        <$> generateAndRasterize (const (FrontAndBack, PolygonFill, ViewPort (V2 0 0) windowSize, DepthRange 0 1)) maxVertices expandedGeometries++      drawWindowColor (const (win, ContextColorOption NoBlending (V3 True True True))) fragmentStream++    isTest <- ("HASKELL_DIST_DIR" `elem`) . map fst <$> liftIO Env.getEnvironment+    Just start <- if isTest then liftIO GLFW.getTime else return (Just 1e100)+    loop start vertexBuffer shader topology win++handler :: GPipeException -> IO ()+handler (GPipeException err) = do+  putStrLn $ "GPipeException: " <> err+  exitFailure+++loop+  :: PrimitiveTopology topology+  => Double+  -> Buffer os (B3 Float, B3 Float, B3 Float)+  -> (PrimitiveArray topology (B3 Float, B3 Float, B3 Float) -> Render os ())+  -> topology+  -> Window os RGBFloat ()+  -> ContextT GLFW.Handle os IO ()+loop start vertexBuffer shader topology win = do+  render $ do+    clearWindowColor win (V3 0.7 0.7 0.7)+    vertexArray <- newVertexArray vertexBuffer+    let primitiveArray = toPrimitiveArray topology vertexArray+    shader primitiveArray+  swapWindowBuffers win++  closeRequested <- GLFW.windowShouldClose win+  Just now <- liftIO GLFW.getTime+  unless (now - start > 1 || closeRequested == Just True) $+    loop start vertexBuffer shader topology win
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tools/playground.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE Arrows          #-}+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies    #-}+module Main (main) where++import           Control.Arrow   (returnA)+import           Control.Lens    ((^.))+import           Data.Function   ((&))+import           Graphics.GPipe+import           Test.ShaderTest (Shaders (Shaders))+import qualified Test.ShaderTest as S++data ShaderAttachment a = ShaderAttachment+  { color  :: V3 a+  , normal :: V3 a+  }++instance FragmentInput a => FragmentInput (ShaderAttachment a) where+  type FragmentFormat (ShaderAttachment a) = ShaderAttachment (FragmentFormat a)+  toFragment = proc ~(ShaderAttachment a b) -> do+    a' <- toFragment -< a+    b' <- toFragment -< b+    returnA -< ShaderAttachment a' b'++instance FragmentCreator a => FragmentCreator (ShaderAttachment a) where+  createFragment = ShaderAttachment+    <$> createFragment+    <*> createFragment++instance AnotherVertexInput a => AnotherVertexInput (ShaderAttachment a) where+  toAnotherVertex = proc ~(ShaderAttachment a b) -> do+    a' <- toAnotherVertex -< a+    b' <- toAnotherVertex -< b+    returnA -< ShaderAttachment a' b'++instance AnotherFragmentInput a => AnotherFragmentInput (ShaderAttachment a) where+  toFragment2 = proc ~(ShaderAttachment a b) -> do+    a' <- toFragment2 -< a+    b' <- toFragment2 -< b+    returnA -< ShaderAttachment a' b'++instance GeometryExplosive a => GeometryExplosive (ShaderAttachment a) where+    exploseGeometry (ShaderAttachment a b) n = exploseGeometry (a, b) n+    declareGeometry ~(ShaderAttachment a b) = declareGeometry (a, b)+    enumerateVaryings ~(ShaderAttachment a b) = enumerateVaryings (a, b)++--------------------------------------------------++topology :: Points+topology = PointList++vertices :: [(V3 Float, V3 Float, V3 Float)]+vertices =+  [ (V3 (x / 5) (y / 5) 0, V3 0 0 1, V3 0.5 1 0.5)+  | x <- [-5..5], y <- [-5..5]+  ]++--------------------------------------------------++viewMat, projMat, projection :: M44 VFloat+viewMat = lookAt (V3 2 2 1) (V3 0 0 0) (V3 0 0 1)+projMat = perspective (pi/3) 1 1 100+projection = projMat !*! viewMat++vert+  :: (V3 VFloat, V3 VFloat, V3 VFloat)+  -> (VPos, ShaderAttachment VFloat)+vert (pos, normal, clr) = (fragPos, sa)+  where+    fragPos = projection !* point pos++    normalMat = transpose (inv44 viewMat)+    sa = ShaderAttachment{color=clr / 10, normal=(normalMat !* point normal) ^. _xyz}++--------------------------------------------------++maxVertices :: Int+maxVertices = 5++geom+  :: GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+  -> Geometry Points (VPos, ShaderAttachment VFloat)+  -> GGenerativeGeometry Triangles (VPos, ShaderAttachment VFloat)+geom g (Point (pos, sa@ShaderAttachment{..})) = g+  & emit (V4 (-0.05) (-0.1) 0 0) color+  & emit (V4   0.05  (-0.1) 0 0) color+  & emit (V4 (-0.05)   0.1  0 0) (color * 2)+  & emit (V4   0.05    0.1  0 0) (color * 2)+  & emit (V4   0.00    0.2  0 0) (color * 2.5)++  & endPrimitive+  where+    emit p c = emitVertexPosition ((pos + p), sa{color=c})++--------------------------------------------------++frag+  :: ShaderAttachment FFloat+  -> V3 FFloat+frag ShaderAttachment{..} = color + normal*0++--------------------------------------------------++main :: IO ()+main = S.main Shaders{topology, vertices, vert, maxVertices, geom, frag}