diff --git a/GPipe-GLFW.cabal b/GPipe-GLFW.cabal --- a/GPipe-GLFW.cabal +++ b/GPipe-GLFW.cabal @@ -1,5 +1,5 @@ name: GPipe-GLFW -version: 1.4.0 +version: 1.4.1 cabal-version: >=1.10 build-type: Simple author: Patrick Redmond @@ -29,7 +29,8 @@ default-language: Haskell2010 exposed-modules: Graphics.GPipe.Context.GLFW Graphics.GPipe.Context.GLFW.Input - Graphics.GPipe.Context.GLFW.Wrapped + 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 @@ -46,4 +47,4 @@ type: git location: https://github.com/plredmond/GPipe-GLFW.git subdir: GPipe-GLFW - tag: v1.4.0 + tag: v1.4.1 diff --git a/src/Graphics/GPipe/Context/GLFW.hs b/src/Graphics/GPipe/Context/GLFW.hs --- a/src/Graphics/GPipe/Context/GLFW.hs +++ b/src/Graphics/GPipe/Context/GLFW.hs @@ -1,24 +1,22 @@ -- | Non interactive applications only need to pass configuration defined here -- into GPipe's 'runContextT' and 'newWindow'. -- --- For user input, see "Graphics.GPipe.Context.GLFW.Input". All other GLFW --- functionality is being incrementally exposed in --- "Graphics.GPipe.Context.GLFW.Wrapped". +-- Interactive applications will need "Graphics.GPipe.Context.GLFW.Input". module Graphics.GPipe.Context.GLFW ( -- * GPipe context handler for GLFW Handle(), GLFWWindow(), -- ** Configuration --- *** Defaults +-- *** Default configs defaultHandleConfig, defaultWindowConfig, --- *** Details +-- *** Custom configs ContextHandlerParameters(HandleConfig, configErrorCallback, configEventPolicy), -- | Configuration for the GLFW handle. -- -- [@'HandleConfig'@] Constructor -- --- [@'configErrorCallback' :: ErrorCallback@] Specify a callback to handle errors captured by GLFW. +-- [@'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(..), @@ -32,7 +30,8 @@ mainstep, -- ** Reexports module Graphics.GPipe.Context.GLFW.Input, -module Graphics.GPipe.Context.GLFW.Wrapped +module Graphics.GPipe.Context.GLFW.Window, +module Graphics.GPipe.Context.GLFW.Misc ) where -- internal @@ -41,4 +40,5 @@ import Graphics.GPipe.Context.GLFW.Handler -- reexports import Graphics.GPipe.Context.GLFW.Input -import Graphics.GPipe.Context.GLFW.Wrapped +import Graphics.GPipe.Context.GLFW.Window +import Graphics.GPipe.Context.GLFW.Misc diff --git a/src/Graphics/GPipe/Context/GLFW/Calls.hs b/src/Graphics/GPipe/Context/GLFW/Calls.hs --- a/src/Graphics/GPipe/Context/GLFW/Calls.hs +++ b/src/Graphics/GPipe/Context/GLFW/Calls.hs @@ -14,13 +14,18 @@ -- 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. debug :: String -> IO () debug msg = do t <- GLFW.getTime tid <- Conc.myThreadId - c <- GLFW.getCurrentContext + c <- getCurrentContext Text.printf "[%03.3fs, %s has %s]: %s\n" (maybe (0/0) id t) (show tid) (show c) msg type OnMain a = IO a -> IO a @@ -75,7 +80,7 @@ -- * This function may be called from any thread. makeContextCurrent :: String -> Maybe GLFW.Window -> IO () makeContextCurrent reason windowHuh = do - ccHuh <- GLFW.getCurrentContext + ccHuh <- getCurrentContext when (ccHuh /= windowHuh) $ do debug $ Text.printf "attaching %s, reason: %s" (show windowHuh) reason GLFW.makeContextCurrent windowHuh @@ -119,6 +124,11 @@ -- * This function may be called from any thread. Access is not synchronized. setWindowShouldClose :: GLFW.Window -> Bool -> IO () setWindowShouldClose window bool = GLFW.setWindowShouldClose window bool + +-- | +-- * This function must only be called from the main thread. +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. diff --git a/src/Graphics/GPipe/Context/GLFW/Format.hs b/src/Graphics/GPipe/Context/GLFW/Format.hs --- a/src/Graphics/GPipe/Context/GLFW/Format.hs +++ b/src/Graphics/GPipe/Context/GLFW/Format.hs @@ -21,8 +21,8 @@ instance Exception [WindowHint] allowedHint :: WindowHint -> Bool -allowedHint (WindowHint'sRGBCapable _) = False allowedHint (WindowHint'Visible _) = False +allowedHint (WindowHint'sRGBCapable _) = False allowedHint (WindowHint'RedBits _) = False allowedHint (WindowHint'GreenBits _) = False allowedHint (WindowHint'BlueBits _) = False diff --git a/src/Graphics/GPipe/Context/GLFW/Handler.hs b/src/Graphics/GPipe/Context/GLFW/Handler.hs --- a/src/Graphics/GPipe/Context/GLFW/Handler.hs +++ b/src/Graphics/GPipe/Context/GLFW/Handler.hs @@ -23,8 +23,8 @@ , ThreadId, myThreadId ) -- thirdparty -import qualified Graphics.GPipe.Context as GPipe (ContextHandler(..), Window(), ContextT(), withContextWindow) -import qualified Graphics.UI.GLFW as GLFW (Window, ErrorCallback) +import qualified Graphics.GPipe as GPipe (ContextHandler(..), Window(), ContextT(), WindowBits, withContextWindow) +import qualified Graphics.UI.GLFW as GLFW (Window, Error) -- local import qualified Graphics.GPipe.Context.GLFW.Calls as Call import qualified Graphics.GPipe.Context.GLFW.Format as Format @@ -59,6 +59,7 @@ data Handle = Handle { handleTid :: ThreadId , handleComm :: RPC.Handle + , handleRaw :: GLFW.Window , handleCtxs :: TVar [MMContext] , handleEventPolicy :: Maybe EventPolicy } @@ -74,14 +75,6 @@ go Nothing = Call.debug (printf "%s: GPipe-GLFW context already closed" callerTag) >> return Nothing go (Just context) = pure <$> action context --- FIXME: May cause crashes in windows (os) because windows (os) requires parent contexts to be uncurrent; easy fix --- | Run the action. If any open context is avaiable, take it and pass it into the action. -withAnyContext :: Handle -> (Maybe Context -> IO a) -> IO a -withAnyContext handle action = readTVarIO (handleCtxs handle) >>= go - where - go (mmContext:ctxs) = withContext "withAnyContext" mmContext (action . pure) >>= maybe (go ctxs) return - go [] = action Nothing - -- | Template for "Run the action with XYZ /if the gpipe window still exists and ABC/." unwrappingGPipeWindow :: MonadIO m => (String -> action -> Handle -> MMContext -> IO (Maybe a)) -- ^ Specialize use of unwrappingGPipeWindow @@ -127,8 +120,8 @@ -- | Configuration for the GLFW handle. data ContextHandlerParameters Handle = HandleConfig - { -- | Specify a callback to handle errors captured by GLFW. - configErrorCallback :: GLFW.ErrorCallback + { -- | 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'). @@ -143,30 +136,10 @@ -- Create a context which shares objects with the contexts created by this -- handle, if any. createContext handle settings = do - unless (null disallowedHints) $ - throwIO $ Format.UnsafeWindowHintsException disallowedHints - -- make a context - window <- withAnyContext handle $ \parent -> do - windowHuh <- Call.createWindow (onMain handle) width height title monitor hints (contextRaw <$> parent) - Call.debug $ printf "contextCreate made %s -> parent %s" (show windowHuh) (show $ contextRaw <$> parent) - case (windowHuh, parent) of - (Just w, _) -> return w - (Nothing, Just _) -> throwIO . CreateSharedWindowException . show $ config {Resource.configHints = hints} - (Nothing, Nothing) -> throwIO . CreateWindowException . show $ config {Resource.configHints = hints} - -- set up context - forM_ intervalHuh $ \interval -> do - Call.makeContextCurrent "apply vsync setting" $ pure window - Call.swapInterval interval - -- wrap up context + window <- createWindow (Just $ handleRaw handle) settings mmContext <- newMVar . pure $ Context window atomically $ modifyTVar (handleCtxs handle) (mmContext :) return $ WWindow (mmContext, handle) - where - config = fromMaybe (defaultWindowConfig "") (snd <$> settings) - Resource.WindowConfig {Resource.configWidth=width, Resource.configHeight=height} = config - Resource.WindowConfig _ _ title monitor _ intervalHuh = config - (userHints, disallowedHints) = partition Format.allowedHint $ Resource.configHints config - hints = userHints ++ Format.bitsToHints (fst <$> settings) ++ Format.unconditionalHints -- Threading assumption: any thread -- @@ -175,11 +148,17 @@ -- -- XXX: If there's a lot of context swapping, change this to RPC to a -- context-private thread running a mainloop. - contextDoAsync _ Nothing _action = do - Call.debug "TODO: contextDoAsync called w/o context; ensure any context is current" + contextDoAsync 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 "contextDoAsync required some context" . pure . handleRaw $ handle) + (const $ return ()) + ccHuh + action contextDoAsync _ (Just (WWindow (mmContext, _))) action = void $ withContext "contextDoAsync" mmContext $ \context -> do - Call.makeContextCurrent "contextDoAsync required it" . pure . contextRaw $ context + Call.makeContextCurrent "contextDoAsync required a specific context" . pure . contextRaw $ context action -- Threading assumption: main thread @@ -231,7 +210,8 @@ ok <- Call.init id -- id RPC because contextHandlerCreate is called only on mainthread unless ok $ throwIO InitException -- wrap up handle - return $ Handle tid comm ctxs eventPolicy + ancestor <- createWindow Nothing Nothing + return $ Handle tid comm ancestor ctxs eventPolicy where HandleConfig errorHandler eventPolicy = config @@ -244,6 +224,29 @@ -- 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 :: Maybe GLFW.Window -> Maybe (GPipe.WindowBits, Resource.WindowConfig) -> IO GLFW.Window +createWindow 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.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 "apply vsync setting" $ pure window + Call.swapInterval interval + -- done + return window + where + config = fromMaybe (defaultWindowConfig "") (snd <$> settings) + Resource.WindowConfig {Resource.configWidth=width, Resource.configHeight=height} = config + Resource.WindowConfig _ _ title monitor _ intervalHuh = config + (userHints, disallowedHints) = partition Format.allowedHint $ Resource.configHints config + hints = userHints ++ Format.bitsToHints (fst <$> settings) ++ Format.unconditionalHints + exc = throwIO . CreateSharedWindowException . show $ config {Resource.configHints = hints} -- | Type to describe the waiting or polling style of event processing -- supported by GLFW. diff --git a/src/Graphics/GPipe/Context/GLFW/Input.hs b/src/Graphics/GPipe/Context/GLFW/Input.hs --- a/src/Graphics/GPipe/Context/GLFW/Input.hs +++ b/src/Graphics/GPipe/Context/GLFW/Input.hs @@ -1,6 +1,5 @@ -- | User input functions covering much of the GLFW __Input guide__: -- . --- For additional functionality see "Graphics.GPipe.Context.GLFW.Wrapped". -- -- Actions are in the GPipe 'GPipe.ContextT' monad when a window handle is required, -- otherwise they are bare reexported IO actions which can be lifted into the 'GPipe.ContextT' monad. diff --git a/src/Graphics/GPipe/Context/GLFW/Misc.hs b/src/Graphics/GPipe/Context/GLFW/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GPipe/Context/GLFW/Misc.hs @@ -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(..)) diff --git a/src/Graphics/GPipe/Context/GLFW/Window.hs b/src/Graphics/GPipe/Context/GLFW/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GPipe/Context/GLFW/Window.hs @@ -0,0 +1,53 @@ +-- | Window manipulation functions covering much of the GLFW __Window guide__: +-- . +-- 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, + +-- * 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()) +--local +import Graphics.GPipe.Context.GLFW.Handler (Handle(..)) +import qualified Graphics.GPipe.Context.GLFW.Calls as Call +import qualified Graphics.GPipe.Context.GLFW.Wrappers as Wrappers + +-- TODO: function docstrings + +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 (flip 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 diff --git a/src/Graphics/GPipe/Context/GLFW/Wrapped.hs b/src/Graphics/GPipe/Context/GLFW/Wrapped.hs deleted file mode 100644 --- a/src/Graphics/GPipe/Context/GLFW/Wrapped.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | Wrapped calls to GLFW-b for application programmer use. For user input see --- "Graphics.GPipe.Context.GLFW.Input". --- --- Actions are in the GPipe 'GPipe.ContextT' monad when a window handle is required, --- otherwise they are bare reexported IO actions which can be lifted into the 'GPipe.ContextT' monad. --- The 'Window' taken by many of these functions is the window resource from GPipe. -module Graphics.GPipe.Context.GLFW.Wrapped where - --- stdlib -import Control.Monad.IO.Class (MonadIO) --- thirdparty -import qualified Graphics.GPipe.Context as GPipe (ContextT, Window()) --- local -import Graphics.GPipe.Context.GLFW.Handler (Handle(..)) -import qualified Graphics.GPipe.Context.GLFW.Calls as Call -import qualified Graphics.GPipe.Context.GLFW.Wrappers as Wrappers - -windowShouldClose :: MonadIO m => GPipe.Window os c ds -> GPipe.ContextT Handle os m (Maybe Bool) -windowShouldClose = Wrappers.withWindow Call.windowShouldClose