diff --git a/GLFW-b.cabal b/GLFW-b.cabal --- a/GLFW-b.cabal +++ b/GLFW-b.cabal @@ -1,9 +1,11 @@ name: GLFW-b -version: 1.4.8.4 +version: 3.3.9.1 category: Graphics author: Brian Lewis -maintainer: Brian Lewis , Schell Scivally +maintainer: Brian Lewis + , Schell Scivally + , Pavel Krajcevski license: BSD3 license-file: LICENSE @@ -16,10 +18,9 @@ . GLFW-b depends on bindings-GLFW (), which, as of the time - of this writing, binds to GLFW 3.2.1, released 2016-08-18 - ( - ). However, these high-level bindings only - point to some of the new features in 3.1 and 3.2. + of this writing, binds to GLFW 3.3.9, released 2023-12-13 + ( + ). . If you've used GLFW < 3 before, you should read the transition guide (). @@ -44,15 +45,16 @@ exposed-modules: Graphics.UI.GLFW + Graphics.UI.GLFW.C other-modules: - Graphics.UI.GLFW.C Graphics.UI.GLFW.Types build-depends: base < 5 , deepseq >= 1.1.0.0 - , bindings-GLFW >= 3.2.1.0 + , array >= 0.5.3.0 + , bindings-GLFW >= 3.3.9.2 -------------------------------------------------------------------------------- @@ -66,14 +68,17 @@ type: exitcode-stdio-1.0 main-is: Test.hs + other-modules: Graphics.UI.GLFW - Graphics.UI.GLFW.C Graphics.UI.GLFW.Types + build-depends: - base < 5 + GLFW-b , HUnit >= 1.3 && < 1.7 - , bindings-GLFW >= 3.2.1.0 + , base < 5 + , array >= 0.5.3.0 + , bindings-GLFW >= 3.3.9.2 , deepseq >= 1.1.0.0 , test-framework == 0.8.* , test-framework-hunit == 0.3.* diff --git a/Graphics/UI/GLFW.hs b/Graphics/UI/GLFW.hs --- a/Graphics/UI/GLFW.hs +++ b/Graphics/UI/GLFW.hs @@ -1,1243 +1,2067 @@ -{-| - -Threading restrictions which apply to the C version of GLFW still apply when -writing @GLFW-b@ programs. See - -(applies here). - -Current context restructions which apply to the C version of GLFW still apply. -See -(applies here). - -@GLFW-b@ wraps callbacks and schedules them to be run after 'pollEvents' and -'waitEvents' in the normal GHC runtime where they aren't subject to the usual -GLFW reentrancy restrictions. See - -(does not apply here). - --} -module Graphics.UI.GLFW - ( -- * Error handling - Error (..) - -- - , setErrorCallback, ErrorCallback - - -- * Initialization and version information - , Version (..) - -- - , init - , terminate - , getVersion - , getVersionString - - -- * Monitor handling - , Monitor - , MonitorState (..) - , VideoMode (..) - , GammaRamp (gammaRampRed, gammaRampGreen, gammaRampBlue) - , makeGammaRamp - -- - , getMonitors - , getPrimaryMonitor - , getMonitorPos - , getMonitorPhysicalSize - , getMonitorName - , setMonitorCallback, MonitorCallback - , getVideoModes - , getVideoMode - , setGamma - , getGammaRamp - , setGammaRamp - - -- * Window handling - , Window - , WindowHint (..) - , FocusState (..) - , IconifyState (..) - , ContextRobustness (..) - , OpenGLProfile (..) - , ClientAPI (..) - -- - , defaultWindowHints - , windowHint - , createWindow - , destroyWindow - , windowShouldClose - , setWindowShouldClose - , setWindowTitle - , getWindowPos - , setWindowPos - , getWindowSize - , setWindowSize - , getFramebufferSize - , iconifyWindow - , restoreWindow - , showWindow - , hideWindow - , getWindowMonitor - , setCursorPos - -- related to c'glfwGetWindowAttrib --. - , getWindowFocused -- | - , getWindowIconified -- | - , getWindowResizable -- | - , getWindowDecorated -- | - , getWindowVisible -- | - , getWindowClientAPI -- | - , getWindowContextVersionMajor -- | - , getWindowContextVersionMinor -- | - , getWindowContextVersionRevision -- | - , getWindowContextRobustness -- | - , getWindowOpenGLForwardCompat -- | - , getWindowOpenGLDebugContext -- | - , getWindowOpenGLProfile --------------' - , setWindowPosCallback, WindowPosCallback - , setWindowSizeCallback, WindowSizeCallback - , setWindowCloseCallback, WindowCloseCallback - , setWindowRefreshCallback, WindowRefreshCallback - , setWindowFocusCallback, WindowFocusCallback - , setWindowIconifyCallback, WindowIconifyCallback - , setFramebufferSizeCallback, FramebufferSizeCallback - , pollEvents - , waitEvents - , postEmptyEvent - - -- * Input handling - , Key (..) - , KeyState (..) - , Joystick (..) - , JoystickButtonState (..) - , MouseButton (..) - , MouseButtonState (..) - , CursorState (..) - , CursorInputMode (..) - , StickyKeysInputMode (..) - , StickyMouseButtonsInputMode (..) - , ModifierKeys (..) - , Image (..) - , Cursor (..) - , StandardCursorShape (..) - -- - -- related to c'glfwSetInputMode ----. - , getCursorInputMode -- | - , setCursorInputMode -- | - , getStickyKeysInputMode -- | - , setStickyKeysInputMode -- | - , getStickyMouseButtonsInputMode -- | - , setStickyMouseButtonsInputMode -----' - , getKey - , getMouseButton - , getCursorPos - , setKeyCallback, KeyCallback - , setCharCallback, CharCallback - , setMouseButtonCallback, MouseButtonCallback - , setCursorPosCallback, CursorPosCallback - , setCursorEnterCallback, CursorEnterCallback - , createCursor - , createStandardCursor - , setCursor - , destroyCursor - , setScrollCallback, ScrollCallback - , setDropCallback, DropCallback - , joystickPresent - , getJoystickAxes - , getJoystickButtons - , getJoystickName - - -- * Time - , getTime - , setTime - - -- * Context - , makeContextCurrent - , getCurrentContext - , swapBuffers - , swapInterval - , extensionSupported - - -- * Clipboard - , getClipboardString - , setClipboardString - ) where - --------------------------------------------------------------------------------- - -import Prelude hiding (init) - -import Control.Monad (when, liftM) -import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef) -import Foreign.C.String (peekCString, withCString) -import Foreign.C.Types (CUInt, CUShort) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Array (advancePtr, allocaArray, peekArray, withArray) -import Foreign.Ptr (FunPtr, freeHaskellFunPtr, nullFunPtr, nullPtr) -import Foreign.StablePtr -import Foreign.Storable (Storable (..)) -import System.IO.Unsafe (unsafePerformIO) - -import Graphics.UI.GLFW.C -import Graphics.UI.GLFW.Types - -import Bindings.GLFW - --------------------------------------------------------------------------------- - --- We store FunPtrs from mk'GLFW*fun in these stored*Fun IORefs. Initialized --- with unsafePerformIO, they are basically mutable global variables. - -storedErrorFun :: IORef C'GLFWerrorfun -storedMonitorFun :: IORef C'GLFWmonitorfun - -storedErrorFun = unsafePerformIO $ newIORef nullFunPtr -storedMonitorFun = unsafePerformIO $ newIORef nullFunPtr - --- These NOINLINE pragmas are due to use of unsafePerformIO. --- See http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-IO-Unsafe.html#v:unsafePerformIO . - -{-# NOINLINE storedErrorFun #-} -{-# NOINLINE storedMonitorFun #-} - -setWindowCallback - :: (c -> IO (FunPtr c)) -- wf wrapper function - -> (h -> c) -- af adapter function - -> (FunPtr c -> IO (FunPtr c)) -- gf c'glfwSet*Callback function - -> (WindowCallbacks -> IORef (FunPtr c)) -- ior accessor for storage location - -> Window -- win window - -> Maybe h -- mcb Haskell callback - -> IO () -setWindowCallback wr af gf ior win mcb = do - pcallbacks <- castPtrToStablePtr `liftM` c'glfwGetWindowUserPointer (unWindow win) - callbacks <- deRefStablePtr pcallbacks - setCallback wr af gf (ior callbacks) mcb - -setCallback - :: (c -> IO (FunPtr c)) -- wf wrapper function - -> (h -> c) -- af adapter function - -> (FunPtr c -> IO (FunPtr c)) -- gf c'glfwSet*Callback function - -> IORef (FunPtr c) -- ior storage location - -> Maybe h -- mcb Haskell callback - -> IO () -setCallback wf af gf ior mcb = do - -- If mcb is Just, make ccb the FunPtr of the adapted callback. Otherwise a - -- null FunPtr. - ccb <- maybe (return nullFunPtr) (wf . af) mcb - -- Call the GLFW callback-setting function. - _ <- gf ccb - -- Store it. - storeCallback ior ccb - -storeCallback :: IORef (FunPtr a) -> FunPtr a -> IO () -storeCallback ior new = do - -- Store the new FunPtr, retrieve the previous one. - prev <- atomicModifyIORef ior (\cur -> (new, cur)) - -- Free the old FunPtr if necessary. - when (prev /= nullFunPtr) $ freeHaskellFunPtr prev - --------------------------------------------------------------------------------- - --- | The error code and also a human-readable error message. -type ErrorCallback = Error -> String -> IO () --- | Fires when the window position changes. -type WindowPosCallback = Window -> Int -> Int -> IO () --- | Fires when the window is resized (in Screen Coordinates, which might not map 1:1 with pixels). -type WindowSizeCallback = Window -> Int -> Int -> IO () --- | Fires when the user is attempting to close the window -type WindowCloseCallback = Window -> IO () --- | Fires when the contents of the window are damaged and they must be refreshed. -type WindowRefreshCallback = Window -> IO () --- | Fires when the window gains or loses input focus. -type WindowFocusCallback = Window -> FocusState -> IO () --- | Fires when the window is iconified (minimized) or not. -type WindowIconifyCallback = Window -> IconifyState -> IO () --- | Fires when the size of the framebuffer for the window changes (in Pixels). -type FramebufferSizeCallback = Window -> Int -> Int -> IO () --- | Fires whenever a mouse button is clicked. -type MouseButtonCallback = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO () --- | Fires every time the cursor position changes. Sub-pixel accuracy is used, when available. -type CursorPosCallback = Window -> Double -> Double -> IO () --- | Fires when the cursor enters or exits the client area of the window. -type CursorEnterCallback = Window -> CursorState -> IO () --- | Fires when the user scrolls the mouse wheel or via touch gesture. -type ScrollCallback = Window -> Double -> Double -> IO () --- | Fires for each press or repeat of keyboard keys (regardless of if it has textual meaning or not, eg Shift) -type KeyCallback = Window -> Key -> Int -> KeyState -> ModifierKeys -> IO () --- | Fires when a complete character codepoint is typed by the user, Shift then 'b' generates "B". -type CharCallback = Window -> Char -> IO () --- | Fires when a monitor is connected or disconnected. -type MonitorCallback = Monitor -> MonitorState -> IO () - --- 3.1 additions - --------------------------------------------------------------------------------- --- CB scheduling - -data ScheduledCallbacks = ScheduledCallbacks - { _forward :: [IO ()] -- Execution iterates this list - , _backward :: [IO ()] -- New schedules prepend here - } - -storedScheduledCallbacks :: IORef ScheduledCallbacks -storedScheduledCallbacks = unsafePerformIO . newIORef $ ScheduledCallbacks [] [] - --- This NOINLINE pragma is due to use of unsafePerformIO. --- See http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-IO-Unsafe.html#v:unsafePerformIO . - -{-# NOINLINE storedScheduledCallbacks #-} - --- This is provided in newer "base" versions. To avoid depending on --- it, it's reimplemented here. Should remove if/when compatibility --- with older base is not an issue: -atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef' ref f = do - b <- atomicModifyIORef ref - (\x -> let (a, b) = f x - in (a, a `seq` b)) - b `seq` return b - -schedule :: IO () -> IO () -schedule act = - atomicModifyIORef' storedScheduledCallbacks $ - \(ScheduledCallbacks oldForward oldBackward) -> - (ScheduledCallbacks oldForward (act : oldBackward), ()) - -splitFirst :: [a] -> (Maybe a, [a]) -splitFirst [] = (Nothing, []) -splitFirst (x:xs) = (Just x, xs) - -getNextScheduled :: IO (Maybe (IO ())) -getNextScheduled = - atomicModifyIORef storedScheduledCallbacks $ - \(ScheduledCallbacks oldForward oldBackward) -> - case oldForward of - [] -> - let (mCb, newForward) = splitFirst (reverse oldBackward) - in (ScheduledCallbacks newForward [], mCb) - (cb:rest) -> -- Eat forward first - (ScheduledCallbacks rest oldBackward, Just cb) - -executeScheduled :: IO () -executeScheduled = do - mcb <- getNextScheduled - case mcb of - Nothing -> return () - Just cb -> cb >> executeScheduled - --------------------------------------------------------------------------------- --- Error handling - --- | Can (and probably should) be used before GLFW initialization. --- See -setErrorCallback :: Maybe ErrorCallback -> IO () -setErrorCallback = setCallback - mk'GLFWerrorfun - (\cb a0 a1 -> do - s <- peekCString a1 - schedule $ cb (fromC a0) s) - c'glfwSetErrorCallback - storedErrorFun - --------------------------------------------------------------------------------- --- Initialization and version information - --- | Attempts to initialize the GLFW library. When the library is not initialized, the only --- allowed functions to call are 'getVersion', 'getVersionString', 'setErrorCallback', --- 'init', and 'terminate'. Returns if the initialization was successful or not. --- See --- and -init :: IO Bool -init = - fromC `fmap` c'glfwInit - --- | Cleans up GLFW and puts the library into an uninitialized state. --- Once you call this, you must initilize the library again. --- Warning: No window's context may be current in another thread when this is called. --- See --- and -terminate :: IO () -terminate = do - c'glfwTerminate - -- Free all stored FunPtrs. - storeCallback storedErrorFun nullFunPtr - storeCallback storedMonitorFun nullFunPtr - --- | Gets the version of the GLFW library that's being used with the current program. --- See -getVersion :: IO Version -getVersion = - allocaArray 3 $ \p -> do - let p0 = p - p1 = p `advancePtr` 1 - p2 = p `advancePtr` 2 - c'glfwGetVersion p0 p1 p2 - v0 <- fromC `fmap` peek p0 - v1 <- fromC `fmap` peek p1 - v2 <- fromC `fmap` peek p2 - return $ Version v0 v1 v2 - --- | Gets the compile-time version string of the GLFW library binary. --- Gives extra info like platform and compile time options used, but you should not --- attempt to parse this to get the GLFW version number. Use 'getVersion' instead. --- See -getVersionString :: IO (Maybe String) -getVersionString = do - p'vs <- c'glfwGetVersionString - if p'vs /= nullPtr - then Just `fmap` peekCString p'vs - else return Nothing - --------------------------------------------------------------------------------- --- Monitor handling - --- | Gets the list of available monitors, if possible. --- See -getMonitors :: IO (Maybe [Monitor]) -getMonitors = - alloca $ \p'n -> do - p'mon <- c'glfwGetMonitors p'n - n <- fromC `fmap` peek p'n - if p'mon == nullPtr || n <= 0 - then return Nothing - else (Just . map fromC) `fmap` peekArray n p'mon - --- | Gets the primary monitor. --- See -getPrimaryMonitor :: IO (Maybe Monitor) -getPrimaryMonitor = do - p'mon <- c'glfwGetPrimaryMonitor - return $ - if p'mon == nullPtr - then Nothing - else Just $ fromC p'mon - --- | Gets the position of the specified monitor within the coordinate space. --- See -getMonitorPos :: Monitor -> IO (Int, Int) -getMonitorPos mon = - allocaArray 2 $ \p -> do - let p'x = p - p'y = p `advancePtr` 1 - c'glfwGetMonitorPos (toC mon) p'x p'y - x <- fromC `fmap` peek p'x - y <- fromC `fmap` peek p'y - return (x, y) - --- | The physical width and height of the monitor. --- See -getMonitorPhysicalSize :: Monitor -> IO (Int, Int) -getMonitorPhysicalSize mon = - allocaArray 2 $ \p -> do - let p'w = p - p'h = p `advancePtr` 1 - c'glfwGetMonitorPhysicalSize (toC mon) p'w p'h - w <- fromC `fmap` peek p'w - h <- fromC `fmap` peek p'h - return (w, h) - --- | A human-readable name for the monitor specified. --- See -getMonitorName :: Monitor -> IO (Maybe String) -getMonitorName mon = do - p'name <- c'glfwGetMonitorName (toC mon) - if p'name == nullPtr - then return Nothing - else Just `fmap` peekCString p'name - --- | Sets a callback for when a monitor is connected or disconnected. --- See -setMonitorCallback :: Maybe MonitorCallback -> IO () -setMonitorCallback = setCallback - mk'GLFWmonitorfun - (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) - c'glfwSetMonitorCallback - storedMonitorFun - --- | Obtains the possible video modes of the monitor. --- See -getVideoModes :: Monitor -> IO (Maybe [VideoMode]) -getVideoModes mon = - alloca $ \p'n -> do - p'vms <- c'glfwGetVideoModes (toC mon) p'n - n <- fromC `fmap` peek p'n - if p'vms == nullPtr || n <= 0 - then return Nothing - else (Just . map fromC) `fmap` peekArray n p'vms - --- | Gets the active video mode of the monitor. --- See -getVideoMode :: Monitor -> IO (Maybe VideoMode) -getVideoMode mon = do - p'vm <- c'glfwGetVideoMode (toC mon) - if p'vm == nullPtr - then return Nothing - else (Just . fromC) `fmap` peek p'vm - --- | Sets the gamma of a monitor. --- See -setGamma :: Monitor -> Double -> IO () -setGamma mon e = - c'glfwSetGamma (toC mon) (toC e) - --- | Gets the gamma ramp in use with the monitor. --- See -getGammaRamp :: Monitor -> IO (Maybe GammaRamp) -getGammaRamp m = do - p'ggr <- c'glfwGetGammaRamp (toC m) - if p'ggr == nullPtr - then return Nothing - else do - ggr <- peek p'ggr - let p'rs = c'GLFWgammaramp'red ggr - p'gs = c'GLFWgammaramp'green ggr - p'bs = c'GLFWgammaramp'blue ggr - cn = c'GLFWgammaramp'size ggr - n = fromC cn - if n == 0 || nullPtr `elem` [p'rs, p'gs, p'bs] - then return Nothing - else do - rs <- map fromC `fmap` peekArray n p'rs - gs <- map fromC `fmap` peekArray n p'gs - bs <- map fromC `fmap` peekArray n p'bs - return $ Just GammaRamp - { gammaRampRed = rs - , gammaRampGreen = gs - , gammaRampBlue = bs - } - --- | Assigns a gamma ramp to use with the given monitor. --- See -setGammaRamp :: Monitor -> GammaRamp -> IO () -setGammaRamp mon gr = - let rs = map toC $ gammaRampRed gr :: [CUShort] - gs = map toC $ gammaRampGreen gr :: [CUShort] - bs = map toC $ gammaRampBlue gr :: [CUShort] - -- GammaRamp's smart constructor ensures that the RGB lists all have - -- equal length, so just use the number of reds. - cn = toC $ length rs :: CUInt - in alloca $ \p'ggr -> - withArray rs $ \p'rs -> - withArray gs $ \p'gs -> - withArray bs $ \p'bs -> do - let ggr = C'GLFWgammaramp - { c'GLFWgammaramp'red = p'rs - , c'GLFWgammaramp'green = p'gs - , c'GLFWgammaramp'blue = p'bs - , c'GLFWgammaramp'size = cn - } - poke p'ggr ggr - c'glfwSetGammaRamp (toC mon) p'ggr - --------------------------------------------------------------------------------- --- Window handling - --- | Sets all the window hints to default. --- See -defaultWindowHints :: IO () -defaultWindowHints = - c'glfwDefaultWindowHints - --- | Hints something to the GLFW windowing system. --- See -windowHint :: WindowHint -> IO () -windowHint wh = - let (t, v) = unpack - in c'glfwWindowHint t v - where - unpack = case wh of - (WindowHint'Resizable x) -> (c'GLFW_RESIZABLE, toC x) - (WindowHint'Visible x) -> (c'GLFW_VISIBLE, toC x) - (WindowHint'Decorated x) -> (c'GLFW_DECORATED, toC x) - (WindowHint'RedBits x) -> (c'GLFW_RED_BITS, toC x) - (WindowHint'GreenBits x) -> (c'GLFW_GREEN_BITS, toC x) - (WindowHint'BlueBits x) -> (c'GLFW_BLUE_BITS, toC x) - (WindowHint'AlphaBits x) -> (c'GLFW_ALPHA_BITS, toC x) - (WindowHint'DepthBits x) -> (c'GLFW_DEPTH_BITS, toC x) - (WindowHint'StencilBits x) -> (c'GLFW_STENCIL_BITS, toC x) - (WindowHint'AccumRedBits x) -> (c'GLFW_ACCUM_RED_BITS, toC x) - (WindowHint'AccumGreenBits x) -> (c'GLFW_ACCUM_GREEN_BITS, toC x) - (WindowHint'AccumBlueBits x) -> (c'GLFW_ACCUM_BLUE_BITS, toC x) - (WindowHint'AccumAlphaBits x) -> (c'GLFW_ACCUM_ALPHA_BITS, toC x) - (WindowHint'AuxBuffers x) -> (c'GLFW_AUX_BUFFERS, toC x) - (WindowHint'Samples x) -> (c'GLFW_SAMPLES, toC x) - (WindowHint'RefreshRate x) -> (c'GLFW_REFRESH_RATE, toC x) - (WindowHint'Stereo x) -> (c'GLFW_STEREO, toC x) - (WindowHint'sRGBCapable x) -> (c'GLFW_SRGB_CAPABLE, toC x) - (WindowHint'ClientAPI x) -> (c'GLFW_CLIENT_API, toC x) - (WindowHint'ContextVersionMajor x) -> (c'GLFW_CONTEXT_VERSION_MAJOR, toC x) - (WindowHint'ContextVersionMinor x) -> (c'GLFW_CONTEXT_VERSION_MINOR, toC x) - (WindowHint'ContextRobustness x) -> (c'GLFW_CONTEXT_ROBUSTNESS, toC x) - (WindowHint'OpenGLForwardCompat x) -> (c'GLFW_OPENGL_FORWARD_COMPAT, toC x) - (WindowHint'OpenGLDebugContext x) -> (c'GLFW_OPENGL_DEBUG_CONTEXT, toC x) - (WindowHint'OpenGLProfile x) -> (c'GLFW_OPENGL_PROFILE, toC x) - --- | Creates a new window. --- Note: If running in GHCI don't forget to `:set -fno-ghci-sandbox` or you --- may run into an assertion failure, segfault or other nasty crash. --- See -createWindow :: Int -- ^ Desired width for the window. - -> Int -- ^ Desired height for the window. - -> String -- ^ Desired title for the window. - -> Maybe Monitor -- ^ Monitor to use in fullscreen mode. - -> Maybe Window -- ^ Window for context object sharing, see - -- . - -> IO (Maybe Window) -createWindow w h title mmon mwin = - withCString title $ \ptitle -> do - charFun <- newIORef nullFunPtr - cursorEnterFun <- newIORef nullFunPtr - cursorPosFun <- newIORef nullFunPtr - framebufferSizeFun <- newIORef nullFunPtr - keyFun <- newIORef nullFunPtr - mouseButtonFun <- newIORef nullFunPtr - scrollFun <- newIORef nullFunPtr - windowCloseFun <- newIORef nullFunPtr - windowFocusFun <- newIORef nullFunPtr - windowIconifyFun <- newIORef nullFunPtr - windowPosFun <- newIORef nullFunPtr - windowRefreshFun <- newIORef nullFunPtr - windowSizeFun <- newIORef nullFunPtr - dropFun <- newIORef nullFunPtr - let callbacks = WindowCallbacks - { storedCharFun = charFun - , storedCursorEnterFun = cursorEnterFun - , storedCursorPosFun = cursorPosFun - , storedFramebufferSizeFun = framebufferSizeFun - , storedKeyFun = keyFun - , storedMouseButtonFun = mouseButtonFun - , storedScrollFun = scrollFun - , storedWindowCloseFun = windowCloseFun - , storedWindowFocusFun = windowFocusFun - , storedWindowIconifyFun = windowIconifyFun - , storedWindowPosFun = windowPosFun - , storedWindowRefreshFun = windowRefreshFun - , storedWindowSizeFun = windowSizeFun - , storedDropFun = dropFun - } - p'win <- c'glfwCreateWindow - (toC w) - (toC h) - ptitle - (maybe nullPtr toC mmon) - (maybe nullPtr toC mwin) - if p'win == nullPtr - then return Nothing - else do callbackPtr <- newStablePtr callbacks - c'glfwSetWindowUserPointer p'win (castStablePtrToPtr callbackPtr) - return $ Just $ fromC p'win - --- | Cleans up a window and all associated resources --- See -destroyWindow :: Window -> IO () -destroyWindow win = do - pcb <- castPtrToStablePtr `liftM` c'glfwGetWindowUserPointer (toC win) - cbs <- deRefStablePtr pcb - c'glfwDestroyWindow (toC win) - - let free callback = do funptr <- readIORef (callback cbs) - when (funptr /= nullFunPtr) $ freeHaskellFunPtr funptr - free storedCharFun - free storedCursorEnterFun - free storedCursorPosFun - free storedFramebufferSizeFun - free storedKeyFun - free storedMouseButtonFun - free storedScrollFun - free storedWindowCloseFun - free storedWindowFocusFun - free storedWindowIconifyFun - free storedWindowPosFun - free storedWindowRefreshFun - free storedWindowSizeFun - freeStablePtr pcb - --- | If the window should close or not. --- See -windowShouldClose :: Window -> IO Bool -windowShouldClose win = - fromC `fmap` c'glfwWindowShouldClose (toC win) - --- | Sets if the window should close or not. --- See -setWindowShouldClose :: Window -> Bool -> IO () -setWindowShouldClose win b = - c'glfwSetWindowShouldClose (toC win) (toC b) - --- | Sets the Title string of the window. --- See -setWindowTitle :: Window -> String -> IO () -setWindowTitle win title = - withCString title $ c'glfwSetWindowTitle (toC win) - --- | Gets the window's position (in Screen Coordinates). --- See -getWindowPos :: Window -> IO (Int, Int) -getWindowPos win = - allocaArray 2 $ \p -> do - let p'x = p - p'y = p `advancePtr` 1 - c'glfwGetWindowPos (toC win) p'x p'y - x <- fromC `fmap` peek p'x - y <- fromC `fmap` peek p'y - return (x, y) - --- | Sets the window's position (in Screen Coordinates). --- See -setWindowPos :: Window -> Int -> Int -> IO () -setWindowPos win x y = - c'glfwSetWindowPos (toC win) (toC x) (toC y) - --- | Gets the size of the window (in Screen Coordinates). --- See -getWindowSize :: Window -> IO (Int, Int) -getWindowSize win = - allocaArray 2 $ \p -> do - let p'w = p - p'h = p `advancePtr` 1 - c'glfwGetWindowSize (toC win) p'w p'h - w <- fromC `fmap` peek p'w - h <- fromC `fmap` peek p'h - return (w, h) - --- | Sets the size of the client area for the window (in Screen Coordinates). --- See -setWindowSize :: Window -> Int -> Int -> IO () -setWindowSize win w h = - c'glfwSetWindowSize (toC win) (toC w) (toC h) - --- | The size of the framebuffer (in Pixels) --- See -getFramebufferSize :: Window -> IO (Int, Int) -getFramebufferSize win = - allocaArray 2 $ \p -> do - let p'w = p - p'h = p `advancePtr` 1 - c'glfwGetFramebufferSize (toC win) p'w p'h - w <- fromC `fmap` peek p'w - h <- fromC `fmap` peek p'h - return (w, h) - --- | Iconifies (minimizes) the window. --- See -iconifyWindow :: Window -> IO () -iconifyWindow = - c'glfwIconifyWindow . toC - --- | Restores the window from an iconified/minimized state. --- See -restoreWindow :: Window -> IO () -restoreWindow = - c'glfwRestoreWindow . toC - --- | Shows the window. --- See -showWindow :: Window -> IO () -showWindow = - c'glfwShowWindow . toC - --- | Hides the window. --- See -hideWindow :: Window -> IO () -hideWindow = - c'glfwHideWindow . toC - --- | Gets the monitor that this window is running on. --- See -getWindowMonitor :: Window -> IO (Maybe Monitor) -getWindowMonitor win = do - p'mon <- c'glfwGetWindowMonitor (toC win) - return $ if p'mon == nullPtr - then Nothing - else Just $ fromC p'mon - --- | Sets the position of the cursor within the window. --- See -setCursorPos :: Window -> Double -> Double -> IO () -setCursorPos win x y = - c'glfwSetCursorPos (toC win) (toC x) (toC y) - --- start of functions related to c'glfwGetWindowAttrib - --- | If the window has focus or not. --- See -getWindowFocused :: Window -> IO FocusState -getWindowFocused win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_FOCUSED - --- | If the window is iconified (minimized) or not. --- See -getWindowIconified :: Window -> IO IconifyState -getWindowIconified win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_ICONIFIED - --- | If the window is resizable or not. --- See -getWindowResizable :: Window -> IO Bool -getWindowResizable win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_RESIZABLE - --- | If the window is decorated or not. --- See -getWindowDecorated :: Window -> IO Bool -getWindowDecorated win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_DECORATED - --- | If the window is visible or not. --- See -getWindowVisible :: Window -> IO Bool -getWindowVisible win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_VISIBLE - --- | The client api for this window. --- See -getWindowClientAPI :: Window -> IO ClientAPI -getWindowClientAPI win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CLIENT_API - --- | The context's "major" version, x.0.0 --- See -getWindowContextVersionMajor :: Window -> IO Int -getWindowContextVersionMajor win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_VERSION_MAJOR - --- | The context's "minor" version, 0.y.0 --- See -getWindowContextVersionMinor :: Window -> IO Int -getWindowContextVersionMinor win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_VERSION_MINOR - --- | The context's "revision" version, 0.0.z --- See -getWindowContextVersionRevision :: Window -> IO Int -getWindowContextVersionRevision win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_REVISION - --- | The context robustness of this window. --- See -getWindowContextRobustness :: Window -> IO ContextRobustness -getWindowContextRobustness win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_ROBUSTNESS - --- | If this window is set for opengl to be forward compatible. --- See -getWindowOpenGLForwardCompat :: Window -> IO Bool -getWindowOpenGLForwardCompat win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_OPENGL_FORWARD_COMPAT - --- | If the window has an opengl debug context --- See -getWindowOpenGLDebugContext :: Window -> IO Bool -getWindowOpenGLDebugContext win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_OPENGL_DEBUG_CONTEXT - --- | Obtains the current opengl profile. --- See -getWindowOpenGLProfile :: Window -> IO OpenGLProfile -getWindowOpenGLProfile win = - fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_OPENGL_PROFILE - --- end of functions related to c'glfwGetWindowAttrib - --- | Sets the callback to use when the window position changes. --- See -setWindowPosCallback :: Window -> Maybe WindowPosCallback -> IO () -setWindowPosCallback win = setWindowCallback - mk'GLFWwindowposfun - (\cb a0 a1 a2 -> - schedule $ cb (fromC a0) (fromC a1) (fromC a2)) - (c'glfwSetWindowPosCallback (toC win)) - storedWindowPosFun - win - --- | Sets the callback to use when the window's size changes. --- See -setWindowSizeCallback :: Window -> Maybe WindowSizeCallback -> IO () -setWindowSizeCallback win = setWindowCallback - mk'GLFWwindowsizefun - (\cb a0 a1 a2 -> - schedule $ cb (fromC a0) (fromC a1) (fromC a2)) - (c'glfwSetWindowSizeCallback (toC win)) - storedWindowSizeFun - win - --- | Sets the callback to use when the user attempts to close the window. --- See -setWindowCloseCallback :: Window -> Maybe WindowCloseCallback -> IO () -setWindowCloseCallback win = setWindowCallback - mk'GLFWwindowclosefun - (. fromC) - (c'glfwSetWindowCloseCallback (toC win)) - storedWindowCloseFun - win - --- | Sets the callback to use when the window's data is partly dead and it should refresh. --- See -setWindowRefreshCallback :: Window -> Maybe WindowRefreshCallback -> IO () -setWindowRefreshCallback win = setWindowCallback - mk'GLFWwindowrefreshfun - (. fromC) - (c'glfwSetWindowRefreshCallback (toC win)) - storedWindowRefreshFun - win - --- | Sets the callback to use when the window gains or loses focus. --- See -setWindowFocusCallback :: Window -> Maybe WindowFocusCallback -> IO () -setWindowFocusCallback win = setWindowCallback - mk'GLFWwindowfocusfun - (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) - (c'glfwSetWindowFocusCallback (toC win)) - storedWindowFocusFun - win - --- | Sets the callback to use when the window is iconified or not (aka, minimized or not). --- See -setWindowIconifyCallback :: Window -> Maybe WindowIconifyCallback -> IO () -setWindowIconifyCallback win = setWindowCallback - mk'GLFWwindowiconifyfun - (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) - (c'glfwSetWindowIconifyCallback (toC win)) - storedWindowIconifyFun - win - --- | Sets the callback to use when the framebuffer's size changes. --- See -setFramebufferSizeCallback :: Window -> Maybe FramebufferSizeCallback -> IO () -setFramebufferSizeCallback win = setWindowCallback - mk'GLFWframebuffersizefun - (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) - (c'glfwSetFramebufferSizeCallback (toC win)) - storedFramebufferSizeFun - win - --- | Checks for any pending events, processes them, and then immediately returns. --- This is most useful for continual rendering, such as games. --- See the -pollEvents :: IO () -pollEvents = c'glfwPollEvents >> executeScheduled - --- | Waits until at least one event is in the queue then processes the queue and returns. --- Requires at least one window to be active for it to sleep. This saves a lot of CPU, and --- is better if you're doing only periodic rendering, such as with an editor program. --- See the -waitEvents :: IO () -waitEvents = c'glfwWaitEvents >> executeScheduled - --- | Creates an empty event within the event queue. Can be called from any --- thread, so you can use this to wake up the main thread that's using --- 'waitEvents' from a secondary thread. --- See the -postEmptyEvent :: IO () -postEmptyEvent = c'glfwPostEmptyEvent - --------------------------------------------------------------------------------- --- Input handling - --- start of glfw{GS}etInputMode-related functions - --- | Gets the current cursor input mode. --- See -getCursorInputMode :: Window -> IO CursorInputMode -getCursorInputMode win = - fromC `fmap` c'glfwGetInputMode (toC win) c'GLFW_CURSOR - --- | Set the cursor input mode. --- See -setCursorInputMode :: Window -> CursorInputMode -> IO () -setCursorInputMode win c = - c'glfwSetInputMode (toC win) c'GLFW_CURSOR (toC c) - --- | Gets the current sticky keys mode. --- See -getStickyKeysInputMode :: Window -> IO StickyKeysInputMode -getStickyKeysInputMode win = - fromC `fmap` c'glfwGetInputMode (toC win) c'GLFW_STICKY_KEYS - --- | Sets if sticky keys should be used or not. --- See -setStickyKeysInputMode :: Window -> StickyKeysInputMode -> IO () -setStickyKeysInputMode win sk = - c'glfwSetInputMode (toC win) c'GLFW_STICKY_KEYS (toC sk) - --- | Gets if sticky mouse buttons are on or not. --- See -getStickyMouseButtonsInputMode :: Window -> IO StickyMouseButtonsInputMode -getStickyMouseButtonsInputMode win = - fromC `fmap` c'glfwGetInputMode (toC win) c'GLFW_STICKY_MOUSE_BUTTONS - --- | Sets if sticky mouse buttons should be used or not. --- See -setStickyMouseButtonsInputMode :: Window -> StickyMouseButtonsInputMode -> IO () -setStickyMouseButtonsInputMode win smb = - c'glfwSetInputMode (toC win) c'GLFW_STICKY_MOUSE_BUTTONS (toC smb) - --- end of glfw{GS}etInputMode-related functions - --- | Gets the state of the specified key. If Stickey Keys isn't enabled then it's possible for --- keyboard polling to miss individual key presses. Use the callback to avoid this. --- See -getKey :: Window -> Key -> IO KeyState -getKey win k = - fromC `fmap` c'glfwGetKey (toC win) (toC k) - --- | Gets the state of a single specified mouse button. If sticky mouse button --- mode isn't enabled it's possible for mouse polling to miss individual mouse events. Use --- the call back to avoid this. --- See -getMouseButton :: Window -> MouseButton -> IO MouseButtonState -getMouseButton win b = - fromC `fmap` c'glfwGetMouseButton (toC win) (toC b) - --- | Returns the position, in screen coodinates, relative to the upper left. --- If the 'CursorInputMode' is "disabled", then results are unbounded by the window size. --- See -getCursorPos :: Window -> IO (Double, Double) -getCursorPos win = - allocaArray 2 $ \p -> do - let p'x = p - p'y = p `advancePtr` 1 - c'glfwGetCursorPos (toC win) p'x p'y - x <- fromC `fmap` peek p'x - y <- fromC `fmap` peek p'y - return (x, y) - --- | Assigns the given callback to use for all keyboard presses and repeats. --- See -setKeyCallback :: Window -> Maybe KeyCallback -> IO () -setKeyCallback win = setWindowCallback - mk'GLFWkeyfun - (\cb a0 a1 a2 a3 a4 -> - schedule $ cb (fromC a0) (fromC a1) (fromC a2) (fromC a3) (fromC a4)) - (c'glfwSetKeyCallback (toC win)) - storedKeyFun - win - --- | Sets the callback to use when the user types a character --- See -setCharCallback :: Window -> Maybe CharCallback -> IO () -setCharCallback win = setWindowCallback - mk'GLFWcharfun - (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) - (c'glfwSetCharCallback (toC win)) - storedCharFun - win - --- | Assigns the callback to run whenver a mouse button is clicked. --- See -setMouseButtonCallback :: Window -> Maybe MouseButtonCallback -> IO () -setMouseButtonCallback win = setWindowCallback - mk'GLFWmousebuttonfun - (\cb a0 a1 a2 a3 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2) (fromC a3)) - (c'glfwSetMouseButtonCallback (toC win)) - storedMouseButtonFun - win - --- | Assigns the callback to run whenver the cursor position changes. --- See -setCursorPosCallback :: Window -> Maybe CursorPosCallback -> IO () -setCursorPosCallback win = setWindowCallback - mk'GLFWcursorposfun - (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) - (c'glfwSetCursorPosCallback (toC win)) - storedCursorPosFun - win - --- | Sets the callback for when the cursor enters or leaves the client area. --- See -setCursorEnterCallback :: Window -> Maybe CursorEnterCallback -> IO () -setCursorEnterCallback win = setWindowCallback - mk'GLFWcursorenterfun - (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) - (c'glfwSetCursorEnterCallback (toC win)) - storedCursorEnterFun - win - --- | Sets the callback to run when the user scrolls with the mouse wheel or a touch gesture. --- See -setScrollCallback :: Window -> Maybe ScrollCallback -> IO () -setScrollCallback win = setWindowCallback - mk'GLFWscrollfun - (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) - (c'glfwSetScrollCallback (toC win)) - storedScrollFun - win - --- | Tests if the joystick is present at all --- See -joystickPresent :: Joystick -> IO Bool -joystickPresent js = - fromC `fmap` c'glfwJoystickPresent (toC js) - --- | Returns the values of all axes of the specified joystick, normalized to between -1.0 and 1.0 --- See -getJoystickAxes :: Joystick -> IO (Maybe [Double]) -getJoystickAxes js = - alloca $ \p'n -> do - p'axes <- c'glfwGetJoystickAxes (toC js) p'n - n <- fromC `fmap` peek p'n - if p'axes == nullPtr || n <= 0 - then return Nothing - else (Just . map fromC) `fmap` peekArray n p'axes - --- | Returns a list of all joystick button states for the specified joystick. --- See -getJoystickButtons :: Joystick -> IO (Maybe [JoystickButtonState]) -getJoystickButtons js = - alloca $ \p'n -> do - p'buttons <- c'glfwGetJoystickButtons (toC js) p'n - n <- fromC `fmap` peek p'n - if p'buttons == nullPtr || n <= 0 - then return Nothing - else (Just . map fromC) `fmap` peekArray n p'buttons - --- | A human-readable name for a Joystick. Not guranteed to be unique. --- See -getJoystickName :: Joystick -> IO (Maybe String) -getJoystickName js = do - p'name <- c'glfwGetJoystickName (toC js) - if p'name == nullPtr - then return Nothing - else Just `fmap` peekCString p'name - --------------------------------------------------------------------------------- --- Time - --- | Returns the time (in seconds) of the GLFW timer. --- This is the amount of time since GLFW was initialized, unless 'setTime' was used. --- The exact resolution is system dependent. --- See -getTime :: IO (Maybe Double) -getTime = do - t <- fromC `fmap` c'glfwGetTime - return $ if t == 0 - then Nothing - else Just t - --- | Sets the GLFW timer to the specified value, which is measured in seconds, and must be positive. --- The value must also be less than ~584 years in seconds (18446744073.0). --- After this the timer begins to count upward at the normal rate. --- See -setTime :: Double -> IO () -setTime = - c'glfwSetTime . toC - --------------------------------------------------------------------------------- --- Context - --- | Makes the context of the specified window the current one for the calling thread. --- A context can only be made current on a single thread at a time, --- and each thread can have only a single current context at a time. --- See -makeContextCurrent :: Maybe Window -> IO () -makeContextCurrent = - c'glfwMakeContextCurrent . maybe nullPtr toC - --- | Obtains which window owns the current context of the calling thread. --- See -getCurrentContext :: IO (Maybe Window) -getCurrentContext = do - p'win <- c'glfwGetCurrentContext - return $ if p'win == nullPtr - then Nothing - else Just $ fromC p'win - --- | Swaps the front and back buffers of the window. --- See -swapBuffers :: Window -> IO () -swapBuffers = - c'glfwSwapBuffers . toC - --- | Sets the number of screen updates that the GPU should wait after 'swapBuffers' before actually swapping the buffers. --- Generates 'Error'NoCurrentContext' if no context is current. --- See -swapInterval :: Int -> IO () -swapInterval = - c'glfwSwapInterval . toC - --- | If the current OpenGL or OpenGL ES context supports the extension specified. --- Generates 'Error'NoCurrentContext' if no context is current. --- See -extensionSupported :: String -> IO Bool -extensionSupported ext = - withCString ext $ \p'ext -> - fromC `fmap` c'glfwExtensionSupported p'ext - --------------------------------------------------------------------------------- --- Clipboard --- http://www.glfw.org/docs/3.1/input.html#clipboard - --- | The window that will own the clipboard contents, and also the clipboard string. --- See -setClipboardString :: Window -> String -> IO () -setClipboardString win s = - withCString s (c'glfwSetClipboardString (toC win)) - --- | Obtains the contents of the system keyboard, if possible. --- Generates 'Error'FormatUnavailable' if the system clipboard is empty or if it's not a UTF-8 string. --- See -getClipboardString :: Window -> IO (Maybe String) -getClipboardString win = do - p's <- c'glfwGetClipboardString (toC win) - if p's == nullPtr - then return Nothing - else Just `fmap` peekCString p's - --------------------------------------------------------------------------------- --- 3.1 additions (http://www.glfw.org/docs/latest/news.html#news_31) --------------------------------------------------------------------------------- - --- Cursor Objects --- http://www.glfw.org/docs/3.1/input.html#cursor_object - --- | Creates a new cursor. -createCursor :: Image -- ^ The desired cursor image. - -> Int -- ^ The desired x-coordinate, in pixels, of the cursor - -- hotspot. - -> Int -- ^ The desired y-coordinate, in pixels, of the cursor - -- hotspot. - -> IO Cursor -createCursor (Image w h pxs) x y = - alloca $ \p'img -> - withArray pxs $ \p'pxs -> do - let img = C'GLFWimage (toC w) - (toC h) - p'pxs - poke p'img img - Cursor `fmap` c'glfwCreateCursor p'img (toC x) (toC y) - --- | Creates a cursor with a standard shape that can be set for a window with --- setCursor. -createStandardCursor :: StandardCursorShape -> IO Cursor -createStandardCursor = (fmap Cursor) . c'glfwCreateStandardCursor . toC - --- | Sets the cursor image to be used when the cursor is over the client area --- of the specified window. The set cursor will only be visible when the cursor --- mode of the window is GLFW_CURSOR_NORMAL. - --- On some platforms, the set cursor may not be visible unless the window also --- has input focus. -setCursor :: Window -> Cursor -> IO () -setCursor (Window wptr) (Cursor cptr) = c'glfwSetCursor wptr cptr - --- | Destroys a cursor previously created with `createCursor`. Any remaining --- cursors will be destroyed by `terminate`. -destroyCursor :: Cursor -> IO () -destroyCursor = c'glfwDestroyCursor . unCursor - --- | A callback that allows for drag and drop support. -type DropCallback = Window -- ^ The window that received the event. - -> [String] -- ^ The file and/or directory path names - -> IO () - --- | Sets the file drop callback of the specified window, which is called when --- one or more dragged files are dropped on the window. -setDropCallback :: Window -> Maybe DropCallback -> IO () -setDropCallback win = setWindowCallback - mk'GLFWdropfun - (\cb w c fs -> do - let count = fromC c - fps <- flip mapM [0..count-1] $ \i -> do - let p = advancePtr fs i - p' <- peek p - peekCString p' - schedule $ cb (fromC w) fps) - (c'glfwSetDropCallback (toC win)) - storedDropFun - win +{-# LANGUAGE ScopedTypeVariables #-} +{-| + +Threading restrictions which apply to the C version of GLFW still apply when +writing @GLFW-b@ programs. See + +(applies here). + +Current context restructions which apply to the C version of GLFW still apply. +See +(applies here). + +@GLFW-b@ wraps callbacks and schedules them to be run after 'pollEvents' and +'waitEvents' in the normal GHC runtime where they aren't subject to the usual +GLFW reentrancy restrictions. See + +(does not apply here). + +-} +module Graphics.UI.GLFW + ( -- * Error handling + Error (..) + -- + , setErrorCallback, ErrorCallback + + -- * Initialization and version information + , Version (..) + -- + , init + , InitHint(..) + , initHint + , terminate + , getVersion + , getVersionString + , getError + , clearError + , rawMouseMotionSupported + + -- * Monitor handling + , Monitor + , MonitorState (..) + , VideoMode (..) + , GammaRamp (gammaRampRed, gammaRampGreen, gammaRampBlue) + , makeGammaRamp + -- + , getMonitors + , getPrimaryMonitor + , getMonitorPos + , getMonitorPhysicalSize + , getMonitorContentScale + , getMonitorWorkarea + , getMonitorName + , setMonitorCallback, MonitorCallback + , getVideoModes + , getVideoMode + , setGamma + , getGammaRamp + , setGammaRamp + + -- * Window handling + , Window + , WindowHint (..) + , WindowAttrib (..) + , ContextRobustness (..) + , OpenGLProfile (..) + , ClientAPI (..) + , ContextCreationAPI (..) + , ContextReleaseBehavior (..) + -- + , defaultWindowHints + , windowHint + , setWindowAttrib + , getWindowAttrib + , createWindow + , destroyWindow + , windowShouldClose + , setWindowShouldClose + , getWindowOpacity + , setWindowOpacity + , setWindowTitle + , getWindowPos + , setWindowPos + , getWindowSize + , setWindowSize + , setWindowSizeLimits + , setWindowAspectRatio + , getWindowFrameSize + , getWindowContentScale + , getFramebufferSize + , setWindowIcon + , iconifyWindow + , restoreWindow + , focusWindow + , maximizeWindow + , showWindow + , hideWindow + , requestWindowAttention + , getWindowMonitor + , setCursorPos + , setFullscreen + , setWindowed + -- related to c'glfwGetWindowAttrib --. + , getWindowFocused -- | + , getWindowMaximized -- | + , getWindowFloating -- | + , getWindowIconified -- | + , getWindowResizable -- | + , getWindowDecorated -- | + , getWindowVisible -- | + , getWindowClientAPI -- | + , getWindowContextCreationAPI -- | + , getWindowContextVersionMajor -- | + , getWindowContextVersionMinor -- | + , getWindowContextVersionRevision -- | + , getWindowContextRobustness -- | + , getWindowContextReleaseBehavior -- | + , getWindowContextNoError -- | + , getWindowOpenGLForwardCompat -- | + , getWindowOpenGLDebugContext -- | + , getWindowOpenGLProfile --------------' + , setWindowPosCallback, WindowPosCallback + , setWindowSizeCallback, WindowSizeCallback + , setWindowCloseCallback, WindowCloseCallback + , setWindowRefreshCallback, WindowRefreshCallback + , setWindowFocusCallback, WindowFocusCallback + , setWindowIconifyCallback, WindowIconifyCallback + , setFramebufferSizeCallback, FramebufferSizeCallback + , setWindowContentScaleCallback, WindowContentScaleCallback + , setWindowMaximizeCallback, WindowMaximizeCallback + , pollEvents + , waitEvents + , waitEventsTimeout + , postEmptyEvent + + -- * Input handling + , Key (..) + , KeyState (..) + , Joystick (..) + , JoystickState (..) + , JoystickButtonState (..) + , MouseButton (..) + , MouseButtonState (..) + , CursorState (..) + , CursorInputMode (..) + , StickyKeysInputMode (..) + , StickyMouseButtonsInputMode (..) + , ModifierKeys (..) + , GamepadButton (..) + , GamepadAxis (..) + , GamepadButtonState (..) + , GamepadState (..) + , Image + , mkImage + , Cursor (..) + , StandardCursorShape (..) + -- + -- related to c'glfwSetInputMode ----. + , getCursorInputMode -- | + , setCursorInputMode -- | + , getRawMouseMotion -- | + , setRawMouseMotion -- | + , getStickyKeysInputMode -- | + , setStickyKeysInputMode -- | + , getStickyMouseButtonsInputMode -- | + , setStickyMouseButtonsInputMode -----' + , getKey + , getKeyName + , getKeyScancode + , getMouseButton + , getCursorPos + , setKeyCallback, KeyCallback + , setCharCallback, CharCallback + , setCharModsCallback, CharModsCallback + , setMouseButtonCallback, MouseButtonCallback + , setCursorPosCallback, CursorPosCallback + , setCursorEnterCallback, CursorEnterCallback + , createCursor + , createStandardCursor + , setCursor + , destroyCursor + , setScrollCallback, ScrollCallback + , setDropCallback, DropCallback + , joystickPresent + , joystickIsGamepad + , getJoystickAxes + , getJoystickButtons + , getJoystickHats, JoystickHatState(..) + , getJoystickName + , getJoystickGUID + , setJoystickCallback, JoystickCallback + , getGamepadName + , getGamepadState + , updateGamepadMappings + + -- * Time + , getTime + , setTime + , getTimerValue + , getTimerFrequency + + -- * Context + , makeContextCurrent + , getCurrentContext + , swapBuffers + , swapInterval + , extensionSupported + + -- * Clipboard + , getClipboardString + , setClipboardString + + -- * Vulkan-related functions + , vulkanSupported + , getRequiredInstanceExtensions + , getInstanceProcAddress + , getPhysicalDevicePresentationSupport + , createWindowSurface + + -- * Native access functions + -- $nativeaccess + , getWin32Adapter + , getWin32Monitor + , getWin32Window + , getWGLContext + , getCocoaMonitor + , getCocoaWindow + , getNSGLContext + , getX11Display + , getX11Adapter + , getX11Monitor + , getX11Window + , getX11SelectionString + , setX11SelectionString + , getGLXContext + , getGLXWindow + , getWaylandDisplay + , getWaylandMonitor + , getWaylandWindow + , getEGLDisplay + , getEGLContext + , getEGLSurface + , getOSMesaContext + , getOSMesaColorBuffer, OSMesaColorBuffer, OSMesaRGBA + , getOSMesaDepthBuffer, OSMesaDepthBuffer + ) where + +-------------------------------------------------------------------------------- + +import Prelude hiding (init) + +import Control.Monad (when, liftM, forM) +import Data.Array.IArray (Array, array) +import Data.Bits (shiftR, shiftL, (.&.), (.|.)) +import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef) +import Data.List (foldl') +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C.String (peekCString, withCString, CString) +import Foreign.C.Types (CUInt, CInt, CUShort, CFloat(..)) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Array (advancePtr, allocaArray, peekArray, withArray) +import Foreign.Ptr ( FunPtr, freeHaskellFunPtr, nullFunPtr, nullPtr + , Ptr, castPtr, plusPtr) +import Foreign.StablePtr +import Foreign.Storable (Storable (..)) +import System.IO.Unsafe (unsafePerformIO) + +import Graphics.UI.GLFW.C +import Graphics.UI.GLFW.Types + +import Bindings.GLFW + +-------------------------------------------------------------------------------- +-- Helper functions + +-- C to haskell float. +hFloat :: CFloat -> Float +hFloat (CFloat f) = f + +-------------------------------------------------------------------------------- + +-- We store FunPtrs from mk'GLFW*fun in these stored*Fun IORefs. Initialized +-- with unsafePerformIO, they are basically mutable global variables. + +storedErrorFun :: IORef C'GLFWerrorfun +storedMonitorFun :: IORef C'GLFWmonitorfun +storedJoystickFun :: IORef C'GLFWjoystickfun + +storedErrorFun = unsafePerformIO $ newIORef nullFunPtr +storedMonitorFun = unsafePerformIO $ newIORef nullFunPtr +storedJoystickFun = unsafePerformIO $ newIORef nullFunPtr + +-- These NOINLINE pragmas are due to use of unsafePerformIO. +-- See http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-IO-Unsafe.html#v:unsafePerformIO . + +{-# NOINLINE storedErrorFun #-} +{-# NOINLINE storedMonitorFun #-} +{-# NOINLINE storedJoystickFun #-} + +setWindowCallback + :: (c -> IO (FunPtr c)) -- wf wrapper function + -> (h -> c) -- af adapter function + -> (FunPtr c -> IO (FunPtr c)) -- gf c'glfwSet*Callback function + -> (WindowCallbacks -> IORef (FunPtr c)) -- ior accessor for storage location + -> Window -- win window + -> Maybe h -- mcb Haskell callback + -> IO () +setWindowCallback wr af gf ior win mcb = do + pcallbacks <- castPtrToStablePtr `liftM` c'glfwGetWindowUserPointer (unWindow win) + callbacks <- deRefStablePtr pcallbacks + setCallback wr af gf (ior callbacks) mcb + +setCallback + :: (c -> IO (FunPtr c)) -- wf wrapper function + -> (h -> c) -- af adapter function + -> (FunPtr c -> IO (FunPtr c)) -- gf c'glfwSet*Callback function + -> IORef (FunPtr c) -- ior storage location + -> Maybe h -- mcb Haskell callback + -> IO () +setCallback wf af gf ior mcb = do + -- If mcb is Just, make ccb the FunPtr of the adapted callback. Otherwise a + -- null FunPtr. + ccb <- maybe (return nullFunPtr) (wf . af) mcb + -- Call the GLFW callback-setting function. + _ <- gf ccb + -- Store it. + storeCallback ior ccb + +storeCallback :: IORef (FunPtr a) -> FunPtr a -> IO () +storeCallback ior new = do + -- Store the new FunPtr, retrieve the previous one. + prev <- atomicModifyIORef ior (\cur -> (new, cur)) + -- Free the old FunPtr if necessary. + when (prev /= nullFunPtr) $ freeHaskellFunPtr prev + +-------------------------------------------------------------------------------- + +-- | The error code and also a human-readable error message. +type ErrorCallback = Error -> String -> IO () +-- | Fires when the window position changes. +type WindowPosCallback = Window -> Int -> Int -> IO () +-- | Fires when the window is resized (in Screen Coordinates, which might not map 1:1 with pixels). +type WindowSizeCallback = Window -> Int -> Int -> IO () +-- | Fires when the user is attempting to close the window +type WindowCloseCallback = Window -> IO () +-- | Fires when the contents of the window are damaged and they must be refreshed. +type WindowRefreshCallback = Window -> IO () +-- | Fires when the window gains or loses input focus. +type WindowFocusCallback = Window -> Bool -> IO () +-- | Fires when the window is iconified (minimized) or not. +type WindowIconifyCallback = Window -> Bool -> IO () +-- | Fires when the size of the framebuffer for the window changes (in Pixels). +type FramebufferSizeCallback = Window -> Int -> Int -> IO () +-- | Fires whenever a mouse button is clicked. +type MouseButtonCallback = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO () +-- | Fires every time the cursor position changes. Sub-pixel accuracy is used, when available. +type CursorPosCallback = Window -> Double -> Double -> IO () +-- | Fires when the cursor enters or exits the client area of the window. +type CursorEnterCallback = Window -> CursorState -> IO () +-- | Fires when the user scrolls the mouse wheel or via touch gesture. +type ScrollCallback = Window -> Double -> Double -> IO () +-- | Fires for each press or repeat of keyboard keys (regardless of if it has textual meaning or not, eg Shift) +type KeyCallback = Window -> Key -> Int -> KeyState -> ModifierKeys -> IO () +-- | Fires when a complete character codepoint is typed by the user, Shift then "b" generates "B". +type CharCallback = Window -> Char -> IO () +-- | Similar to 'CharCallback', fires when a complete unicode codepoint is typed by the user. +type CharModsCallback = Window -> Char -> ModifierKeys -> IO () +-- | Fires when a monitor is connected or disconnected. +type MonitorCallback = Monitor -> MonitorState -> IO () +-- | Fires when a joystick is connected or disconnected. +type JoystickCallback = Joystick -> JoystickState -> IO () +-- | Fires when a window is rescaled +type WindowContentScaleCallback = Window -> Float -> Float -> IO () +-- | Fires when a window is maximized or restored. Returns True if the window +-- was maximized and False if the window was restored. +type WindowMaximizeCallback = Window -> Bool -> IO () +-------------------------------------------------------------------------------- +-- CB scheduling + +data ScheduledCallbacks = ScheduledCallbacks + { _forward :: [IO ()] -- Execution iterates this list + , _backward :: [IO ()] -- New schedules prepend here + } + +storedScheduledCallbacks :: IORef ScheduledCallbacks +storedScheduledCallbacks = unsafePerformIO . newIORef $ ScheduledCallbacks [] [] + +-- This NOINLINE pragma is due to use of unsafePerformIO. +-- See http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-IO-Unsafe.html#v:unsafePerformIO . + +{-# NOINLINE storedScheduledCallbacks #-} + +-- This is provided in newer "base" versions. To avoid depending on +-- it, it's reimplemented here. Should remove if/when compatibility +-- with older base is not an issue: +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef' ref f = do + b <- atomicModifyIORef ref + (\x -> let (a, b) = f x + in (a, a `seq` b)) + b `seq` return b + +schedule :: IO () -> IO () +schedule act = + atomicModifyIORef' storedScheduledCallbacks $ + \(ScheduledCallbacks oldForward oldBackward) -> + (ScheduledCallbacks oldForward (act : oldBackward), ()) + +splitFirst :: [a] -> (Maybe a, [a]) +splitFirst [] = (Nothing, []) +splitFirst (x:xs) = (Just x, xs) + +getNextScheduled :: IO (Maybe (IO ())) +getNextScheduled = + atomicModifyIORef storedScheduledCallbacks $ + \(ScheduledCallbacks oldForward oldBackward) -> + case oldForward of + [] -> + let (mCb, newForward) = splitFirst (reverse oldBackward) + in (ScheduledCallbacks newForward [], mCb) + (cb:rest) -> -- Eat forward first + (ScheduledCallbacks rest oldBackward, Just cb) + +executeScheduled :: IO () +executeScheduled = do + mcb <- getNextScheduled + case mcb of + Nothing -> return () + Just cb -> cb >> executeScheduled + +-------------------------------------------------------------------------------- +-- Error handling + +-- | Can (and probably should) be used before GLFW initialization. +-- See +setErrorCallback :: Maybe ErrorCallback -> IO () +setErrorCallback = setCallback + mk'GLFWerrorfun + (\cb a0 a1 -> do + s <- peekCString a1 + schedule $ cb (fromC a0) s) + c'glfwSetErrorCallback + storedErrorFun + +-------------------------------------------------------------------------------- +-- Image utility functions + +withGLFWImage :: Image -> (Ptr C'GLFWimage -> IO a) -> IO a +withGLFWImage (Image w h pxs) f = + alloca $ \p'img -> + withArray pxs $ \p'pxs -> do + poke p'img $ C'GLFWimage (toC w) (toC h) p'pxs + f p'img + +-------------------------------------------------------------------------------- +-- Initialization and version information + +-- | Attempts to initialize the GLFW library. When the library is not initialized, the only +-- allowed functions to call are 'getVersion', 'getVersionString', 'setErrorCallback', +-- 'init', and 'terminate'. Returns if the initialization was successful or not. +-- See +-- and +init :: IO Bool +init = fromC `fmap` c'glfwInit + +-- | This function sets hints for the next initialization of GLFW. See +-- +initHint :: InitHint -> Bool -> IO () +initHint hint val = c'glfwInitHint (toC hint) (toC val) + +-- | Cleans up GLFW and puts the library into an uninitialized state. +-- Once you call this, you must initilize the library again. +-- Warning: No window's context may be current in another thread when this is called. +-- See +-- and . This +-- function is not . +terminate :: IO () +terminate = do + c'glfwTerminate + -- Free all stored FunPtrs. + storeCallback storedErrorFun nullFunPtr + storeCallback storedMonitorFun nullFunPtr + storeCallback storedJoystickFun nullFunPtr + +-- | Gets the version of the GLFW library that's being used with the current program. +-- See +getVersion :: IO Version +getVersion = + allocaArray 3 $ \p -> do + let p0 = p + p1 = p `advancePtr` 1 + p2 = p `advancePtr` 2 + c'glfwGetVersion p0 p1 p2 + v0 <- fromC `fmap` peek p0 + v1 <- fromC `fmap` peek p1 + v2 <- fromC `fmap` peek p2 + return $ Version v0 v1 v2 + +-- | Gets the compile-time version string of the GLFW library binary. +-- Gives extra info like platform and compile time options used, but you should not +-- attempt to parse this to get the GLFW version number. Use 'getVersion' instead. +-- See +getVersionString :: IO (Maybe String) +getVersionString = do + p'vs <- c'glfwGetVersionString + if p'vs /= nullPtr + then Just `fmap` peekCString p'vs + else return Nothing + +-- | Returns and clears the error code of the last error that occurred on the +-- calling thread and a UTF-8 encoded human-readable description of it. If no +-- error has occurred since the last call, it returns Nothing. +getError :: IO (Maybe (Error, String)) +getError = alloca $ \errStr -> do + err <- c'glfwGetError errStr + if err == c'GLFW_NO_ERROR + then return Nothing + else peek errStr + >>= peekCString + >>= (\s -> return $ Just (fromC err, s)) + +-- | Clears the last error as would be retreived by 'getError'. +clearError :: IO () +clearError = c'glfwGetError nullPtr >> pure () + +-- | Returns true if raw mouse motion is supported on the current system. +-- See +rawMouseMotionSupported :: IO Bool +rawMouseMotionSupported = fromC <$> c'glfwRawMouseMotionSupported + +-------------------------------------------------------------------------------- +-- Monitor handling + +-- | Gets the list of available monitors, if possible. +-- See +getMonitors :: IO (Maybe [Monitor]) +getMonitors = + alloca $ \p'n -> do + p'mon <- c'glfwGetMonitors p'n + n <- fromC `fmap` peek p'n + if p'mon == nullPtr || n <= 0 + then return Nothing + else (Just . map fromC) `fmap` peekArray n p'mon + +-- | Gets the primary monitor. +-- See +getPrimaryMonitor :: IO (Maybe Monitor) +getPrimaryMonitor = do + p'mon <- c'glfwGetPrimaryMonitor + return $ + if p'mon == nullPtr + then Nothing + else Just $ fromC p'mon + +-- | Gets the position of the specified monitor within the coordinate space. +-- See +getMonitorPos :: Monitor -> IO (Int, Int) +getMonitorPos mon = + allocaArray 2 $ \p -> do + let p'x = p + p'y = p `advancePtr` 1 + c'glfwGetMonitorPos (toC mon) p'x p'y + x <- fromC `fmap` peek p'x + y <- fromC `fmap` peek p'y + return (x, y) + +-- | The physical width and height of the monitor. +-- See +getMonitorPhysicalSize :: Monitor -> IO (Int, Int) +getMonitorPhysicalSize mon = + allocaArray 2 $ \p -> do + let p'w = p + p'h = p `advancePtr` 1 + c'glfwGetMonitorPhysicalSize (toC mon) p'w p'h + w <- fromC `fmap` peek p'w + h <- fromC `fmap` peek p'h + return (w, h) + +-- | A human-readable name for the monitor specified. +-- See +getMonitorName :: Monitor -> IO (Maybe String) +getMonitorName mon = do + p'name <- c'glfwGetMonitorName (toC mon) + if p'name == nullPtr + then return Nothing + else Just `fmap` peekCString p'name + +-- | Sets a callback for when a monitor is connected or disconnected. +-- See +setMonitorCallback :: Maybe MonitorCallback -> IO () +setMonitorCallback = setCallback + mk'GLFWmonitorfun + (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) + c'glfwSetMonitorCallback + storedMonitorFun + +-- | Obtains the possible video modes of the monitor. +-- See +getVideoModes :: Monitor -> IO (Maybe [VideoMode]) +getVideoModes mon = + alloca $ \p'n -> do + p'vms <- c'glfwGetVideoModes (toC mon) p'n + n <- fromC `fmap` peek p'n + if p'vms == nullPtr || n <= 0 + then return Nothing + else (Just . map fromC) `fmap` peekArray n p'vms + +-- | Gets the active video mode of the monitor. +-- See +getVideoMode :: Monitor -> IO (Maybe VideoMode) +getVideoMode mon = do + p'vm <- c'glfwGetVideoMode (toC mon) + if p'vm == nullPtr + then return Nothing + else (Just . fromC) `fmap` peek p'vm + +-- | Sets the gamma of a monitor. +-- See +setGamma :: Monitor -> Double -> IO () +setGamma mon e = + c'glfwSetGamma (toC mon) (toC e) + +-- | Gets the gamma ramp in use with the monitor. +-- See +getGammaRamp :: Monitor -> IO (Maybe GammaRamp) +getGammaRamp m = do + p'ggr <- c'glfwGetGammaRamp (toC m) + if p'ggr == nullPtr + then return Nothing + else do + ggr <- peek p'ggr + let p'rs = c'GLFWgammaramp'red ggr + p'gs = c'GLFWgammaramp'green ggr + p'bs = c'GLFWgammaramp'blue ggr + cn = c'GLFWgammaramp'size ggr + n = fromC cn + if n == 0 || nullPtr `elem` [p'rs, p'gs, p'bs] + then return Nothing + else do + rs <- map fromC `fmap` peekArray n p'rs + gs <- map fromC `fmap` peekArray n p'gs + bs <- map fromC `fmap` peekArray n p'bs + return $ Just GammaRamp + { gammaRampRed = rs + , gammaRampGreen = gs + , gammaRampBlue = bs + } + +-- | Assigns a gamma ramp to use with the given monitor. +-- See +setGammaRamp :: Monitor -> GammaRamp -> IO () +setGammaRamp mon gr = + let rs = map toC $ gammaRampRed gr :: [CUShort] + gs = map toC $ gammaRampGreen gr :: [CUShort] + bs = map toC $ gammaRampBlue gr :: [CUShort] + -- GammaRamp's smart constructor ensures that the RGB lists all have + -- equal length, so just use the number of reds. + cn = toC $ length rs :: CUInt + in alloca $ \p'ggr -> + withArray rs $ \p'rs -> + withArray gs $ \p'gs -> + withArray bs $ \p'bs -> do + let ggr = C'GLFWgammaramp + { c'GLFWgammaramp'red = p'rs + , c'GLFWgammaramp'green = p'gs + , c'GLFWgammaramp'blue = p'bs + , c'GLFWgammaramp'size = cn + } + poke p'ggr ggr + c'glfwSetGammaRamp (toC mon) p'ggr + +-- | This function retrieves the content scale for the specified monitor. The +-- content scale is the ratio between the current DPI and the platform's default +-- DPI. +-- See +getMonitorContentScale :: Monitor -> IO (Float, Float) +getMonitorContentScale mon = + alloca $ \p'x -> + alloca $ \p'y -> do + c'glfwGetMonitorContentScale (toC mon) p'x p'y + CFloat x <- peek p'x + CFloat y <- peek p'y + return (x, y) + +-- | This function returns the position, in screen coordinates, of the +-- upper-left corner of the work area of the specified monitor along with the +-- work area size in screen coordinates. Returned tuple is: +-- (xPos, yPos, width, height) +-- See +getMonitorWorkarea :: Monitor -> IO (Int, Int, Int, Int) +getMonitorWorkarea mon = + alloca $ \p'x -> + alloca $ \p'y -> + alloca $ \p'w -> + alloca $ \p'h -> do + c'glfwGetMonitorWorkarea (toC mon) p'x p'y p'w p'h + x <- fromC <$> peek p'x + y <- fromC <$> peek p'y + w <- fromC <$> peek p'w + h <- fromC <$> peek p'h + return (x, y, w, h) + +-------------------------------------------------------------------------------- +-- Window handling + +-- | Sets all the window hints to default. +-- See +defaultWindowHints :: IO () +defaultWindowHints = + c'glfwDefaultWindowHints + +setStringHint :: CInt -> String -> IO () +setStringHint hint = flip withCString (c'glfwWindowHintString hint) + +-- | Hints something to the GLFW windowing system. +-- See +-- +-- and +-- +windowHint :: WindowHint -> IO () +windowHint (WindowHint'Resizable x) = + c'glfwWindowHint c'GLFW_RESIZABLE (toC x) +windowHint (WindowHint'Visible x) = + c'glfwWindowHint c'GLFW_VISIBLE (toC x) +windowHint (WindowHint'Decorated x) = + c'glfwWindowHint c'GLFW_DECORATED (toC x) +windowHint (WindowHint'RedBits x) = + c'glfwWindowHint c'GLFW_RED_BITS (toC x) +windowHint (WindowHint'GreenBits x) = + c'glfwWindowHint c'GLFW_GREEN_BITS (toC x) +windowHint (WindowHint'BlueBits x) = + c'glfwWindowHint c'GLFW_BLUE_BITS (toC x) +windowHint (WindowHint'AlphaBits x) = + c'glfwWindowHint c'GLFW_ALPHA_BITS (toC x) +windowHint (WindowHint'DepthBits x) = + c'glfwWindowHint c'GLFW_DEPTH_BITS (toC x) +windowHint (WindowHint'StencilBits x) = + c'glfwWindowHint c'GLFW_STENCIL_BITS (toC x) +windowHint (WindowHint'AccumRedBits x) = + c'glfwWindowHint c'GLFW_ACCUM_RED_BITS (toC x) +windowHint (WindowHint'AccumGreenBits x) = + c'glfwWindowHint c'GLFW_ACCUM_GREEN_BITS (toC x) +windowHint (WindowHint'AccumBlueBits x) = + c'glfwWindowHint c'GLFW_ACCUM_BLUE_BITS (toC x) +windowHint (WindowHint'AccumAlphaBits x) = + c'glfwWindowHint c'GLFW_ACCUM_ALPHA_BITS (toC x) +windowHint (WindowHint'AuxBuffers x) = + c'glfwWindowHint c'GLFW_AUX_BUFFERS (toC x) +windowHint (WindowHint'Samples x) = + c'glfwWindowHint c'GLFW_SAMPLES (toC x) +windowHint (WindowHint'RefreshRate x) = + c'glfwWindowHint c'GLFW_REFRESH_RATE (toC x) +windowHint (WindowHint'DoubleBuffer x) = + c'glfwWindowHint c'GLFW_DOUBLEBUFFER (toC x) +windowHint (WindowHint'Stereo x) = + c'glfwWindowHint c'GLFW_STEREO (toC x) +windowHint (WindowHint'sRGBCapable x) = + c'glfwWindowHint c'GLFW_SRGB_CAPABLE (toC x) +windowHint (WindowHint'Floating x) = + c'glfwWindowHint c'GLFW_FLOATING (toC x) +windowHint (WindowHint'Focused x) = + c'glfwWindowHint c'GLFW_FOCUSED (toC x) +windowHint (WindowHint'Maximized x) = + c'glfwWindowHint c'GLFW_MAXIMIZED (toC x) +windowHint (WindowHint'AutoIconify x) = + c'glfwWindowHint c'GLFW_AUTO_ICONIFY (toC x) +windowHint (WindowHint'ClientAPI x) = + c'glfwWindowHint c'GLFW_CLIENT_API (toC x) +windowHint (WindowHint'ContextCreationAPI x) = + c'glfwWindowHint c'GLFW_CONTEXT_CREATION_API (toC x) +windowHint (WindowHint'ContextVersionMajor x) = + c'glfwWindowHint c'GLFW_CONTEXT_VERSION_MAJOR (toC x) +windowHint (WindowHint'ContextVersionMinor x) = + c'glfwWindowHint c'GLFW_CONTEXT_VERSION_MINOR (toC x) +windowHint (WindowHint'ContextRobustness x) = + c'glfwWindowHint c'GLFW_CONTEXT_ROBUSTNESS (toC x) +windowHint (WindowHint'ContextReleaseBehavior x) = + c'glfwWindowHint c'GLFW_CONTEXT_RELEASE_BEHAVIOR (toC x) +windowHint (WindowHint'ContextNoError x) = + c'glfwWindowHint c'GLFW_CONTEXT_NO_ERROR (toC x) +windowHint (WindowHint'OpenGLForwardCompat x) = + c'glfwWindowHint c'GLFW_OPENGL_FORWARD_COMPAT (toC x) +windowHint (WindowHint'OpenGLDebugContext x) = + c'glfwWindowHint c'GLFW_OPENGL_DEBUG_CONTEXT (toC x) +windowHint (WindowHint'OpenGLProfile x) = + c'glfwWindowHint c'GLFW_OPENGL_PROFILE (toC x) +windowHint (WindowHint'TransparentFramebuffer x) = + c'glfwWindowHint c'GLFW_TRANSPARENT_FRAMEBUFFER (toC x) +windowHint (WindowHint'CenterCursor x) = + c'glfwWindowHint c'GLFW_CENTER_CURSOR (toC x) +windowHint (WindowHint'FocusOnShow x) = + c'glfwWindowHint c'GLFW_FOCUS_ON_SHOW (toC x) +windowHint (WindowHint'ScaleToMonitor x) = + c'glfwWindowHint c'GLFW_SCALE_TO_MONITOR (toC x) +windowHint (WindowHint'CocoaRetinaFramebuffer x) = + c'glfwWindowHint c'GLFW_COCOA_RETINA_FRAMEBUFFER (toC x) +windowHint (WindowHint'CocoaGraphicsSwitching x) = + c'glfwWindowHint c'GLFW_COCOA_GRAPHICS_SWITCHING (toC x) +windowHint (WindowHint'CocoaFrameName x) = setStringHint c'GLFW_COCOA_FRAME_NAME x +windowHint (WindowHint'X11ClassName x) = setStringHint c'GLFW_X11_CLASS_NAME x +windowHint (WindowHint'X11InstanceName x) = setStringHint c'GLFW_X11_INSTANCE_NAME x + +-- | Creates a new window. +-- Note: If running in GHCI don't forget to @:set -fno-ghci-sandbox@ or you +-- may run into an assertion failure, segfault or other nasty crash. +-- See +createWindow :: Int -- ^ Desired width for the window. + -> Int -- ^ Desired height for the window. + -> String -- ^ Desired title for the window. + -> Maybe Monitor -- ^ Monitor to use in fullscreen mode. + -> Maybe Window -- ^ Window for context object sharing, see + -- . + -> IO (Maybe Window) +createWindow w h title mmon mwin = + withCString title $ \ptitle -> do + charFun <- newIORef nullFunPtr + charModsFun <- newIORef nullFunPtr + cursorEnterFun <- newIORef nullFunPtr + cursorPosFun <- newIORef nullFunPtr + framebufferSizeFun <- newIORef nullFunPtr + keyFun <- newIORef nullFunPtr + mouseButtonFun <- newIORef nullFunPtr + scrollFun <- newIORef nullFunPtr + windowCloseFun <- newIORef nullFunPtr + windowFocusFun <- newIORef nullFunPtr + windowIconifyFun <- newIORef nullFunPtr + windowPosFun <- newIORef nullFunPtr + windowRefreshFun <- newIORef nullFunPtr + windowSizeFun <- newIORef nullFunPtr + windowContentScaleFun <- newIORef nullFunPtr + windowMaximizeFun <- newIORef nullFunPtr + dropFun <- newIORef nullFunPtr + let callbacks = WindowCallbacks + { storedCharFun = charFun + , storedCharModsFun = charModsFun + , storedCursorEnterFun = cursorEnterFun + , storedCursorPosFun = cursorPosFun + , storedFramebufferSizeFun = framebufferSizeFun + , storedKeyFun = keyFun + , storedMouseButtonFun = mouseButtonFun + , storedScrollFun = scrollFun + , storedWindowCloseFun = windowCloseFun + , storedWindowFocusFun = windowFocusFun + , storedWindowIconifyFun = windowIconifyFun + , storedWindowPosFun = windowPosFun + , storedWindowRefreshFun = windowRefreshFun + , storedWindowSizeFun = windowSizeFun + , storedWindowContentScaleFun = windowContentScaleFun + , storedWindowMaximizeFun = windowMaximizeFun + , storedDropFun = dropFun + } + p'win <- c'glfwCreateWindow + (toC w) + (toC h) + ptitle + (maybe nullPtr toC mmon) + (maybe nullPtr toC mwin) + if p'win == nullPtr + then return Nothing + else do callbackPtr <- newStablePtr callbacks + c'glfwSetWindowUserPointer p'win (castStablePtrToPtr callbackPtr) + -- Not sure why this isn't the default... + c'glfwSetInputMode p'win c'GLFW_LOCK_KEY_MODS (toC True) + return $ Just $ fromC p'win + +-- | Cleans up a window and all associated resources +-- See . +-- This function is not . +destroyWindow :: Window -> IO () +destroyWindow win = do + pcb <- castPtrToStablePtr `liftM` c'glfwGetWindowUserPointer (toC win) + cbs <- deRefStablePtr pcb + c'glfwDestroyWindow (toC win) + + let free callback = do funptr <- readIORef (callback cbs) + when (funptr /= nullFunPtr) $ freeHaskellFunPtr funptr + free storedCharFun + free storedCharModsFun + free storedCursorEnterFun + free storedCursorPosFun + free storedFramebufferSizeFun + free storedKeyFun + free storedMouseButtonFun + free storedScrollFun + free storedWindowCloseFun + free storedWindowFocusFun + free storedWindowIconifyFun + free storedWindowPosFun + free storedWindowRefreshFun + free storedWindowSizeFun + freeStablePtr pcb + +-- | Returns the value of an attribute of the specified window or its OpenGL or +-- OpenGL ES context. +-- See +getWindowAttrib :: Window -> WindowAttrib -> IO Bool +getWindowAttrib win attrib = + fromC <$> c'glfwGetWindowAttrib (toC win) (toC attrib) + +-- | Sets the value of an attribute of the specified window. +-- See +setWindowAttrib :: Window -> WindowAttrib -> Bool -> IO () +setWindowAttrib win attrib = c'glfwSetWindowAttrib (toC win) (toC attrib) . toC + +-- | If the window should close or not. +-- See +windowShouldClose :: Window -> IO Bool +windowShouldClose win = + fromC `fmap` c'glfwWindowShouldClose (toC win) + +-- | Sets if the window should close or not. +-- See +setWindowShouldClose :: Window -> Bool -> IO () +setWindowShouldClose win b = + c'glfwSetWindowShouldClose (toC win) (toC b) + +-- | Returns the opacity of the window, including any decorations. +-- See IO Float +getWindowOpacity = fmap hFloat . c'glfwGetWindowOpacity . toC + +-- | Sets the opacity of the window, including any decorations +-- See +setWindowOpacity :: Window -> Float -> IO () +setWindowOpacity win op = c'glfwSetWindowOpacity (toC win) (CFloat op) + +-- | Sets the Title string of the window. +-- See +setWindowTitle :: Window -> String -> IO () +setWindowTitle win title = + withCString title $ c'glfwSetWindowTitle (toC win) + +-- | Gets the window's position (in screen coordinates). +-- See +getWindowPos :: Window -> IO (Int, Int) +getWindowPos win = + allocaArray 2 $ \p -> do + let p'x = p + p'y = p `advancePtr` 1 + c'glfwGetWindowPos (toC win) p'x p'y + x <- fromC `fmap` peek p'x + y <- fromC `fmap` peek p'y + return (x, y) + +-- | Sets the window's position (in screen coordinates). +-- See +setWindowPos :: Window -> Int -> Int -> IO () +setWindowPos win x y = + c'glfwSetWindowPos (toC win) (toC x) (toC y) + +-- | Gets the size of the window (in screen coordinates). +-- See +getWindowSize :: Window -> IO (Int, Int) +getWindowSize win = + allocaArray 2 $ \p -> do + let p'w = p + p'h = p `advancePtr` 1 + c'glfwGetWindowSize (toC win) p'w p'h + w <- fromC `fmap` peek p'w + h <- fromC `fmap` peek p'h + return (w, h) + +-- | Gets the size of the frame around the window (in screen coordinates). This +-- size includes the title bar, if the window has one. Not to be confused with +-- 'getFramebufferSize', which gets the size of the rendering area. +-- See +getWindowFrameSize :: Window -> IO (Int, Int, Int, Int) +getWindowFrameSize win = + allocaArray 4 $ \p -> do + let p'l = p + p't = p `advancePtr` 1 + p'r = p `advancePtr` 2 + p'b = p `advancePtr` 3 + c'glfwGetWindowFrameSize (toC win) p'l p't p'r p'b + l <- fromC `fmap` peek p'l + t <- fromC `fmap` peek p't + r <- fromC `fmap` peek p'r + b <- fromC `fmap` peek p'b + return (l, t, r, b) + +-- | Sets the size of the client area for the window (in screen coordinates). +-- See +setWindowSize :: Window -> Int -> Int -> IO () +setWindowSize win w h = + c'glfwSetWindowSize (toC win) (toC w) (toC h) + +-- | Sets the size limits of the client area of the specified window. If the +-- window is full screen, the size limits only take effect once it is made +-- windowed. If the window is not resizable this function does nothing. Pass +-- 'Nothing' in any argument to disable the limit. +-- See +setWindowSizeLimits :: Window + -> Maybe Int + -- ^ The minimum width, in screen coordinates, of the client + -- area. + -> Maybe Int + -- ^ The minimum height, in screen coordinates, of the + -- client area. + -> Maybe Int + -- ^ The maximum width, in screen coordinates, of the client + -- area. + -> Maybe Int + -- ^ The maximum height, in screen coordinates, of the + -- client area. + -> IO () +setWindowSizeLimits win min'w min'h max'w max'h = + c'glfwSetWindowSizeLimits (toC win) (toC min'w) (toC min'h) + (toC max'w) (toC max'h) + +-- | Sets the required aspect ratio of the client area of the specified window. +-- Pass Nothing to disable the limit. +-- See +setWindowAspectRatio :: Window -> Maybe (Int, Int) -> IO () +setWindowAspectRatio win Nothing = + c'glfwSetWindowAspectRatio (toC win) c'GLFW_DONT_CARE c'GLFW_DONT_CARE +setWindowAspectRatio win (Just (w, h)) = + c'glfwSetWindowAspectRatio (toC win) (toC w) (toC h) + +-- | This function retrieves the content scale for the specified window. The +-- content scale is the ratio between the current DPI and the platform's +-- default DPI. +-- See +getWindowContentScale :: Window -> IO (Float, Float) +getWindowContentScale win = + alloca $ \p'x -> + alloca $ \p'y -> do + c'glfwGetWindowContentScale (toC win) p'x p'y + CFloat x <- peek p'x + CFloat y <- peek p'y + return (x, y) + +-- | The size of the framebuffer (in Pixels) +-- See +getFramebufferSize :: Window -> IO (Int, Int) +getFramebufferSize win = + allocaArray 2 $ \p -> do + let p'w = p + p'h = p `advancePtr` 1 + c'glfwGetFramebufferSize (toC win) p'w p'h + w <- fromC `fmap` peek p'w + h <- fromC `fmap` peek p'h + return (w, h) + +-- | Sets the icon of the specified window. The system will try to find the +-- image with the dimensions closest to the ones required by the platform. This +-- image is then scaled and used as the icon for that size. Good sizes are +-- 16x16, 32x32, and 48x48. Pass the empty list to reset to the default icon. +-- Has no effect on OS X (See the ) +setWindowIcon :: Window -> [Image] -> IO () +setWindowIcon win [] = c'glfwSetWindowIcon (toC win) 0 nullPtr +setWindowIcon win imgs = + let arrSizeBytes = length imgs * sizeOf (undefined :: C'GLFWimage) + + addNextImage :: [Image] -> Int -> Ptr C'GLFWimage -> IO () + addNextImage [] numImages ptr = + c'glfwSetWindowIcon (toC win) (toC numImages) ptr + + addNextImage (img:rest) idx ptr = + withGLFWImage img $ \p'img -> do + c'img <- peek p'img + pokeElemOff ptr idx c'img + addNextImage rest (idx + 1) ptr + in allocaBytes arrSizeBytes $ addNextImage imgs 0 + +-- | Iconifies (minimizes) the window. +-- See +iconifyWindow :: Window -> IO () +iconifyWindow = c'glfwIconifyWindow . toC + +-- | Restores the window from an iconified/minimized state. +-- See +restoreWindow :: Window -> IO () +restoreWindow = c'glfwRestoreWindow . toC + +-- | Brings the specified window to front and sets input focus. The window +-- should already be visible and not iconified. +-- See +focusWindow :: Window -> IO () +focusWindow = c'glfwFocusWindow . toC + +-- | Maximizes the specified window if it was not already maximized. +-- See +maximizeWindow :: Window -> IO () +maximizeWindow = c'glfwMaximizeWindow . toC + +-- | Shows the window. +-- See +showWindow :: Window -> IO () +showWindow = c'glfwShowWindow . toC + +-- | Hides the window. +-- See +hideWindow :: Window -> IO () +hideWindow = c'glfwHideWindow . toC + +-- | Requests user attention to the specified window. +-- See +requestWindowAttention :: Window -> IO () +requestWindowAttention = c'glfwRequestWindowAttention . toC + +-- | Gets the monitor that this window is running on, provided the window is +-- fullscreen. +-- See +getWindowMonitor :: Window -> IO (Maybe Monitor) +getWindowMonitor win = do + p'mon <- c'glfwGetWindowMonitor (toC win) + return $ if p'mon == nullPtr + then Nothing + else Just $ fromC p'mon + +-- | Sets the position of the cursor within the window. +-- See +setCursorPos :: Window -> Double -> Double -> IO () +setCursorPos win x y = + c'glfwSetCursorPos (toC win) (toC x) (toC y) + +-- | Makes a window fullscreen on the given monitor. The number of red, green, +-- and blue bits is ignored. Note, this shouldn't be used to update the +-- resolution of a fullscreen window. Use 'setWindowSize' instead. +-- See +setFullscreen :: Window -> Monitor -> VideoMode -> IO () +setFullscreen win mon (VideoMode width height _ _ _ refresh) = + c'glfwSetWindowMonitor (toC win) (toC mon) 0 0 (toC width) (toC height) (toC refresh) + +-- | Updates a window to be windowed instead of fullscreen. Note, this shouldn't +-- be used to update the position or size of a window. Use 'setWindowPos' and +-- 'setWindowSize' instead. +-- See +setWindowed :: Window + -> Int -- ^ The width of the client area + -> Int -- ^ The height of the client area + -> Int -- ^ The x position of the window + -> Int -- ^ The y position of the window + -> IO () +setWindowed win width height x y = + c'glfwSetWindowMonitor (toC win) nullPtr (toC x) (toC y) (toC width) (toC height) 0 + +-- start of functions related to c'glfwGetWindowAttrib + +-- | If the window has focus or not. +-- See +getWindowFocused :: Window -> IO Bool +getWindowFocused win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_FOCUSED + +-- | If the window is maximized or not. +-- See +getWindowMaximized :: Window -> IO Bool +getWindowMaximized win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_MAXIMIZED + +-- | If the window has been set to be 'always on top' or not. +-- See +getWindowFloating :: Window -> IO Bool +getWindowFloating win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_FLOATING + +-- | If the window is iconified (minimized) or not. +-- See +getWindowIconified :: Window -> IO Bool +getWindowIconified win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_ICONIFIED + +-- | If the window is resizable or not. +-- See +getWindowResizable :: Window -> IO Bool +getWindowResizable win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_RESIZABLE + +-- | If the window is decorated or not. +-- See +getWindowDecorated :: Window -> IO Bool +getWindowDecorated win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_DECORATED + +-- | If the window is visible or not. +-- See +getWindowVisible :: Window -> IO Bool +getWindowVisible win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_VISIBLE + +-- | The client api for this window. +-- See +getWindowClientAPI :: Window -> IO ClientAPI +getWindowClientAPI win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CLIENT_API + +-- | Returns the context creation API used to create the specified window. +-- See +getWindowContextCreationAPI :: Window -> IO ContextCreationAPI +getWindowContextCreationAPI win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_CREATION_API + +-- | The context's "major" version, x.0.0 +-- See +getWindowContextVersionMajor :: Window -> IO Int +getWindowContextVersionMajor win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_VERSION_MAJOR + +-- | The context's "minor" version, 0.y.0 +-- See +getWindowContextVersionMinor :: Window -> IO Int +getWindowContextVersionMinor win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_VERSION_MINOR + +-- | The context's "revision" version, 0.0.z +-- See +getWindowContextVersionRevision :: Window -> IO Int +getWindowContextVersionRevision win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_REVISION + +-- | The context robustness of this window. +-- See +getWindowContextRobustness :: Window -> IO ContextRobustness +getWindowContextRobustness win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_ROBUSTNESS + +-- | Returns the context release behavior. +-- See +getWindowContextReleaseBehavior :: Window -> IO ContextReleaseBehavior +getWindowContextReleaseBehavior win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_RELEASE_BEHAVIOR + +-- | Returns true if the window is set to NO_ERROR (see the +-- +-- extension. +getWindowContextNoError :: Window -> IO Bool +getWindowContextNoError win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_CONTEXT_NO_ERROR + +-- | If this window is set for opengl to be forward compatible. +-- See +getWindowOpenGLForwardCompat :: Window -> IO Bool +getWindowOpenGLForwardCompat win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_OPENGL_FORWARD_COMPAT + +-- | If the window has an opengl debug context +-- See +getWindowOpenGLDebugContext :: Window -> IO Bool +getWindowOpenGLDebugContext win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_OPENGL_DEBUG_CONTEXT + +-- | Obtains the current opengl profile. +-- See +getWindowOpenGLProfile :: Window -> IO OpenGLProfile +getWindowOpenGLProfile win = + fromC `fmap` c'glfwGetWindowAttrib (toC win) c'GLFW_OPENGL_PROFILE + +-- end of functions related to c'glfwGetWindowAttrib + +-- | Sets the callback to use when the window position changes. +-- See +setWindowPosCallback :: Window -> Maybe WindowPosCallback -> IO () +setWindowPosCallback win = setWindowCallback + mk'GLFWwindowposfun + (\cb a0 a1 a2 -> + schedule $ cb (fromC a0) (fromC a1) (fromC a2)) + (c'glfwSetWindowPosCallback (toC win)) + storedWindowPosFun + win + +-- | Sets the callback to use when the window's size changes. +-- See +setWindowSizeCallback :: Window -> Maybe WindowSizeCallback -> IO () +setWindowSizeCallback win = setWindowCallback + mk'GLFWwindowsizefun + (\cb a0 a1 a2 -> + schedule $ cb (fromC a0) (fromC a1) (fromC a2)) + (c'glfwSetWindowSizeCallback (toC win)) + storedWindowSizeFun + win + +-- | Sets the callback to use when the user attempts to close the window. +-- See +setWindowCloseCallback :: Window -> Maybe WindowCloseCallback -> IO () +setWindowCloseCallback win = setWindowCallback + mk'GLFWwindowclosefun + (. fromC) + (c'glfwSetWindowCloseCallback (toC win)) + storedWindowCloseFun + win + +-- | Sets the callback to use when the window's data is partly dead and it should refresh. +-- See +setWindowRefreshCallback :: Window -> Maybe WindowRefreshCallback -> IO () +setWindowRefreshCallback win = setWindowCallback + mk'GLFWwindowrefreshfun + (. fromC) + (c'glfwSetWindowRefreshCallback (toC win)) + storedWindowRefreshFun + win + +-- | Sets the callback to use when the window gains or loses focus. +-- See +setWindowFocusCallback :: Window -> Maybe WindowFocusCallback -> IO () +setWindowFocusCallback win = setWindowCallback + mk'GLFWwindowfocusfun + (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) + (c'glfwSetWindowFocusCallback (toC win)) + storedWindowFocusFun + win + +-- | Sets the callback to use when the window is iconified or not (aka, minimized or not). +-- See +setWindowIconifyCallback :: Window -> Maybe WindowIconifyCallback -> IO () +setWindowIconifyCallback win = setWindowCallback + mk'GLFWwindowiconifyfun + (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) + (c'glfwSetWindowIconifyCallback (toC win)) + storedWindowIconifyFun + win + +-- | Sets the callback for when the content scale of the window changes. +-- See +setWindowContentScaleCallback :: Window -> Maybe WindowContentScaleCallback -> IO () +setWindowContentScaleCallback win = setWindowCallback + mk'GLFWwindowcontentscalefun + (\cb w (CFloat f1) (CFloat f2) -> schedule $ cb (fromC w) f1 f2) + (c'glfwSetWindowContentScaleCallback (toC win)) + storedWindowContentScaleFun + win + +-- | Sets the maximization callback of the specified window, which is called +-- when the window is maximized or restored. +-- See +setWindowMaximizeCallback :: Window -> Maybe WindowMaximizeCallback -> IO () +setWindowMaximizeCallback win = setWindowCallback + mk'GLFWwindowmaximizefun + (\cb w x -> schedule $ cb (fromC w) (fromC x)) + (c'glfwSetWindowMaximizeCallback (toC win)) + storedWindowMaximizeFun + win + +-- | Sets the callback to use when the framebuffer's size changes. +-- See +setFramebufferSizeCallback :: Window -> Maybe FramebufferSizeCallback -> IO () +setFramebufferSizeCallback win = setWindowCallback + mk'GLFWframebuffersizefun + (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) + (c'glfwSetFramebufferSizeCallback (toC win)) + storedFramebufferSizeFun + win + +-- | Checks for any pending events, processes them, and then immediately returns. +-- This is most useful for continual rendering, such as games. +-- See the . This +-- function is not . +pollEvents :: IO () +pollEvents = c'glfwPollEvents >> executeScheduled + +-- | Waits until at least one event is in the queue then processes the queue and returns. +-- Requires at least one window to be active for it to sleep. This saves a lot of CPU, and +-- is better if you're doing only periodic rendering, such as with an editor program. +-- See the . This +-- function is not . +waitEvents :: IO () +waitEvents = c'glfwWaitEvents >> executeScheduled + +-- | Same as 'waitEvents', with a timeout after which the function returns. +-- See the . This +-- function is not . +waitEventsTimeout :: Double -> IO () +waitEventsTimeout seconds = + c'glfwWaitEventsTimeout (toC seconds) >> executeScheduled + +-- | Creates an empty event within the event queue. Can be called from any +-- thread, so you can use this to wake up the main thread that's using +-- 'waitEvents' from a secondary thread. +-- See the +postEmptyEvent :: IO () +postEmptyEvent = c'glfwPostEmptyEvent + +-------------------------------------------------------------------------------- +-- Input handling + +-- start of glfw{GS}etInputMode-related functions + +-- | Gets the current cursor input mode. +-- See +getCursorInputMode :: Window -> IO CursorInputMode +getCursorInputMode win = + fromC `fmap` c'glfwGetInputMode (toC win) c'GLFW_CURSOR + +-- | Set the cursor input mode. +-- See +setCursorInputMode :: Window -> CursorInputMode -> IO () +setCursorInputMode win c = + c'glfwSetInputMode (toC win) c'GLFW_CURSOR (toC c) + +-- | Sets the cursor to receive raw input, if available (See +-- rawMouseMotionSupported and +-- +setRawMouseMotion :: Window -> Bool -> IO () +setRawMouseMotion win toggle = do + supported <- rawMouseMotionSupported + if not supported + then putStrLn "WARNING -- Asked to set raw mouse motion but is unsupported" + else c'glfwSetInputMode (toC win) c'GLFW_RAW_MOUSE_MOTION (toC toggle) + +-- | Returns whether or not we've currently enabled raw mouse motion. +-- See +getRawMouseMotion :: Window -> IO Bool +getRawMouseMotion win = + fromC <$> c'glfwGetInputMode (toC win) c'GLFW_RAW_MOUSE_MOTION + +-- | Gets the current sticky keys mode. +-- See +getStickyKeysInputMode :: Window -> IO StickyKeysInputMode +getStickyKeysInputMode win = + fromC `fmap` c'glfwGetInputMode (toC win) c'GLFW_STICKY_KEYS + +-- | Sets if sticky keys should be used or not. +-- See +setStickyKeysInputMode :: Window -> StickyKeysInputMode -> IO () +setStickyKeysInputMode win sk = + c'glfwSetInputMode (toC win) c'GLFW_STICKY_KEYS (toC sk) + +-- | Gets if sticky mouse buttons are on or not. +-- See +getStickyMouseButtonsInputMode :: Window -> IO StickyMouseButtonsInputMode +getStickyMouseButtonsInputMode win = + fromC `fmap` c'glfwGetInputMode (toC win) c'GLFW_STICKY_MOUSE_BUTTONS + +-- | Sets if sticky mouse buttons should be used or not. +-- See +setStickyMouseButtonsInputMode :: Window -> StickyMouseButtonsInputMode -> IO () +setStickyMouseButtonsInputMode win smb = + c'glfwSetInputMode (toC win) c'GLFW_STICKY_MOUSE_BUTTONS (toC smb) + +-- end of glfw{GS}etInputMode-related functions + +-- | Gets the state of the specified key. If Stickey Keys isn't enabled then it's possible for +-- keyboard polling to miss individual key presses. Use the callback to avoid this. +-- See +getKey :: Window -> Key -> IO KeyState +getKey win k = + fromC `fmap` c'glfwGetKey (toC win) (toC k) + +-- | Returns the localized name of the specified printable key. This is intended +-- for displaying key bindings to the user. The scancode is used if the provided +-- 'Key' isn't printable. If the scancode maps to a non-printable key as well, +-- then 'Nothing' is returned. +-- See +getKeyName :: Key -> Int -> IO (Maybe String) +getKeyName k scancode = do + cstr <- c'glfwGetKeyName (toC k) (toC scancode) + if cstr == nullPtr + then return Nothing + else Just `fmap` peekCString cstr + +-- | This function returns the platform-specific scancode of the specified key. +-- See +getKeyScancode :: Key -> IO Int +getKeyScancode = fmap fromC . c'glfwGetKeyScancode . toC + +-- | Gets the state of a single specified mouse button. If sticky mouse button +-- mode isn't enabled it's possible for mouse polling to miss individual mouse events. Use +-- the call back to avoid this. +-- See +getMouseButton :: Window -> MouseButton -> IO MouseButtonState +getMouseButton win b = + fromC `fmap` c'glfwGetMouseButton (toC win) (toC b) + +-- | Returns the position, in screen coodinates, relative to the upper left. +-- If the 'CursorInputMode' is "disabled", then results are unbounded by the window size. +-- See +getCursorPos :: Window -> IO (Double, Double) +getCursorPos win = + allocaArray 2 $ \p -> do + let p'x = p + p'y = p `advancePtr` 1 + c'glfwGetCursorPos (toC win) p'x p'y + x <- fromC `fmap` peek p'x + y <- fromC `fmap` peek p'y + return (x, y) + +-- | Assigns the given callback to use for all keyboard presses and repeats. +-- See +setKeyCallback :: Window -> Maybe KeyCallback -> IO () +setKeyCallback win = setWindowCallback + mk'GLFWkeyfun + (\cb a0 a1 a2 a3 a4 -> + schedule $ cb (fromC a0) (fromC a1) (fromC a2) (fromC a3) (fromC a4)) + (c'glfwSetKeyCallback (toC win)) + storedKeyFun + win + +-- | Sets the callback to use when the user types a character +-- See +setCharCallback :: Window -> Maybe CharCallback -> IO () +setCharCallback win = setWindowCallback + mk'GLFWcharfun + (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) + (c'glfwSetCharCallback (toC win)) + storedCharFun + win + +-- | Sets the callback to use with Unicode characters regardless of what +-- modifier keys are used. +-- See +setCharModsCallback :: Window -> Maybe CharModsCallback -> IO () +setCharModsCallback win = setWindowCallback + mk'GLFWcharmodsfun + (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) + (c'glfwSetCharModsCallback (toC win)) + storedCharModsFun + win + +-- | Assigns the callback to run whenver a mouse button is clicked. +-- See +setMouseButtonCallback :: Window -> Maybe MouseButtonCallback -> IO () +setMouseButtonCallback win = setWindowCallback + mk'GLFWmousebuttonfun + (\cb a0 a1 a2 a3 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2) (fromC a3)) + (c'glfwSetMouseButtonCallback (toC win)) + storedMouseButtonFun + win + +-- | Assigns the callback to run whenver the cursor position changes. +-- See +setCursorPosCallback :: Window -> Maybe CursorPosCallback -> IO () +setCursorPosCallback win = setWindowCallback + mk'GLFWcursorposfun + (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) + (c'glfwSetCursorPosCallback (toC win)) + storedCursorPosFun + win + +-- | Sets the callback for when the cursor enters or leaves the client area. +-- See +setCursorEnterCallback :: Window -> Maybe CursorEnterCallback -> IO () +setCursorEnterCallback win = setWindowCallback + mk'GLFWcursorenterfun + (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) + (c'glfwSetCursorEnterCallback (toC win)) + storedCursorEnterFun + win + +-- | Sets the callback to run when the user scrolls with the mouse wheel or a touch gesture. +-- See +setScrollCallback :: Window -> Maybe ScrollCallback -> IO () +setScrollCallback win = setWindowCallback + mk'GLFWscrollfun + (\cb a0 a1 a2 -> schedule $ cb (fromC a0) (fromC a1) (fromC a2)) + (c'glfwSetScrollCallback (toC win)) + storedScrollFun + win + +-- | Tests if the joystick is present at all +-- See +joystickPresent :: Joystick -> IO Bool +joystickPresent = fmap fromC . c'glfwJoystickPresent . toC + +-- | Returns the values of all axes of the specified joystick, normalized to between -1.0 and 1.0 +-- See +getJoystickAxes :: Joystick -> IO (Maybe [Double]) +getJoystickAxes js = alloca $ \p'n -> do + p'axes <- c'glfwGetJoystickAxes (toC js) p'n + n <- fromC <$> peek p'n + if p'axes == nullPtr || n <= 0 + then return Nothing + else (Just . map fromC) <$> peekArray n p'axes + +-- | Returns a list of all joystick button states for the specified joystick. +-- See +getJoystickButtons :: Joystick -> IO (Maybe [JoystickButtonState]) +getJoystickButtons js = alloca $ \p'n -> do + p'buttons <- c'glfwGetJoystickButtons (toC js) p'n + n <- fromC <$> peek p'n + if p'buttons == nullPtr || n <= 0 + then return Nothing + else (Just . map fromC) <$> peekArray n p'buttons + +-- | Returns a list of all hats of the specified joystick. +-- See +getJoystickHats :: Joystick -> IO (Maybe [JoystickHatState]) +getJoystickHats js = alloca $ \p'n -> do + p'hats <- c'glfwGetJoystickHats (toC js) p'n + n <- fromC <$> peek p'n + if p'hats == nullPtr || n <= 0 + then return Nothing + else (Just . map fromC) <$> peekArray n p'hats + +-- | A human-readable name for a Joystick. Not guranteed to be unique. +-- See +getJoystickName :: Joystick -> IO (Maybe String) +getJoystickName js = do + p'name <- c'glfwGetJoystickName (toC js) + if p'name == nullPtr + then return Nothing + else Just <$> peekCString p'name + +-- | Sets a callback for when a joystick is connected or disconnected. +-- See +setJoystickCallback :: Maybe JoystickCallback -> IO () +setJoystickCallback = setCallback + mk'GLFWjoystickfun + (\cb a0 a1 -> schedule $ cb (fromC a0) (fromC a1)) + c'glfwSetJoystickCallback + storedJoystickFun + +-- | Adds the specified SDL_GameControllerDB gamepad mappings. +-- See +updateGamepadMappings :: String -> IO Bool +updateGamepadMappings = + flip withCString $ \s -> fromC <$> c'glfwUpdateGamepadMappings s + +-- | This function returns whether the specified joystick is both present and +-- has a gamepad mapping. +-- See +joystickIsGamepad :: Joystick -> IO Bool +joystickIsGamepad = fmap (== c'GLFW_TRUE) . c'glfwJoystickIsGamepad . toC + +-- | This function returns the SDL compatible GUID of the specified joystick. +-- See +getJoystickGUID :: Joystick -> IO (Maybe String) +getJoystickGUID js = do + p'guid <- c'glfwGetJoystickGUID (toC js) + if p'guid == nullPtr + then return Nothing + else Just <$> peekCString p'guid + +-- | This function returns the human-readable name of the gamepad from the +-- gamepad mapping assigned to the specified joystick. +-- See +getGamepadName :: Joystick -> IO (Maybe String) +getGamepadName js = do + p'name <- c'glfwGetGamepadName (toC js) + if p'name == nullPtr + then return Nothing + else Just <$> peekCString p'name + +-- | This function retrives the state of the specified joystick remapped to an +-- Xbox-like gamepad. +-- See +getGamepadState :: Joystick -> IO (Maybe GamepadState) +getGamepadState js = alloca $ \p'gps -> do + hasGamepad <- fromC <$> c'glfwGetGamepadState (toC js) p'gps + if hasGamepad + then do + gps <- peek p'gps + return $ Just GamepadState + { getButtonState = fromC . (c'GLFWgamepadstate'buttons gps !!) + . (fromIntegral :: CInt -> Int) + . toC + , getAxisState = hFloat + . (c'GLFWgamepadstate'axes gps !!) + . (fromIntegral :: CInt -> Int) + . toC + } + else return Nothing + +-------------------------------------------------------------------------------- +-- Time + +-- | Returns the time (in seconds) of the GLFW timer. +-- This is the amount of time since GLFW was initialized, unless 'setTime' was used. +-- The exact resolution is system dependent. +-- See +getTime :: IO (Maybe Double) +getTime = do + t <- fromC `fmap` c'glfwGetTime + return $ if t == 0 + then Nothing + else Just t + +-- | Sets the GLFW timer to the specified value, which is measured in seconds, and must be positive. +-- The value must also be less than ~584 years in seconds (18446744073.0). +-- After this the timer begins to count upward at the normal rate. +-- See +setTime :: Double -> IO () +setTime = c'glfwSetTime . toC + +-- | Returns the current value of the raw timer, measured in 1 / frequency +-- seconds. The frequency can be queried using getTimerFrequency. +-- See +getTimerValue :: IO Word64 +getTimerValue = c'glfwGetTimerValue + +-- | Returns the frequency, in Hz, of the raw timer. +-- See +getTimerFrequency :: IO Word64 +getTimerFrequency = c'glfwGetTimerFrequency + +-------------------------------------------------------------------------------- +-- Context + +-- | Makes the context of the specified window the current one for the calling thread. +-- A context can only be made current on a single thread at a time, +-- and each thread can have only a single current context at a time. +-- See +makeContextCurrent :: Maybe Window -> IO () +makeContextCurrent = + c'glfwMakeContextCurrent . maybe nullPtr toC + +-- | Obtains which window owns the current context of the calling thread. +-- See +getCurrentContext :: IO (Maybe Window) +getCurrentContext = do + p'win <- c'glfwGetCurrentContext + return $ if p'win == nullPtr + then Nothing + else Just $ fromC p'win + +-- | Swaps the front and back buffers of the window. +-- See +swapBuffers :: Window -> IO () +swapBuffers = + c'glfwSwapBuffers . toC + +-- | Sets the number of screen updates that the GPU should wait after 'swapBuffers' before actually swapping the buffers. +-- Generates 'Error'NoCurrentContext' if no context is current. +-- See +swapInterval :: Int -> IO () +swapInterval = + c'glfwSwapInterval . toC + +-- | If the current OpenGL or OpenGL ES context supports the extension specified. +-- Generates 'Error'NoCurrentContext' if no context is current. +-- See +extensionSupported :: String -> IO Bool +extensionSupported ext = + withCString ext $ \p'ext -> + fromC `fmap` c'glfwExtensionSupported p'ext + +-------------------------------------------------------------------------------- +-- Clipboard +-- http://www.glfw.org/docs/3.3/input.html#clipboard + +-- | The window that will own the clipboard contents, and also the clipboard string. +-- See +setClipboardString :: Window -> String -> IO () +setClipboardString win s = + withCString s (c'glfwSetClipboardString (toC win)) + +-- | Obtains the contents of the system keyboard, if possible. +-- Generates 'Error'FormatUnavailable' if the system clipboard is empty or if it's not a UTF-8 string. +-- See +getClipboardString :: Window -> IO (Maybe String) +getClipboardString win = do + p's <- c'glfwGetClipboardString (toC win) + if p's == nullPtr + then return Nothing + else Just `fmap` peekCString p's + +-------------------------------------------------------------------------------- +-- 3.1 additions (http://www.glfw.org/docs/3.1/news.html#news_31) +-------------------------------------------------------------------------------- + +-- Cursor Objects +-- http://www.glfw.org/docs/3.3/input.html#cursor_object + +-- | Creates a new cursor. +createCursor :: Image -- ^ The desired cursor image. + -> Int -- ^ The desired x-coordinate, in pixels, of the cursor + -- hotspot. + -> Int -- ^ The desired y-coordinate, in pixels, of the cursor + -- hotspot. + -> IO Cursor +createCursor img x y = + withGLFWImage img $ \p'img -> + Cursor `fmap` c'glfwCreateCursor p'img (toC x) (toC y) + +-- | Creates a cursor with a standard shape that can be set for a window with +-- setCursor. +createStandardCursor :: StandardCursorShape -> IO Cursor +createStandardCursor = (fmap Cursor) . c'glfwCreateStandardCursor . toC + +-- | Sets the cursor image to be used when the cursor is over the client area +-- of the specified window. The set cursor will only be visible when the cursor +-- mode of the window is @GLFW_CURSOR_NORMAL@. + +-- On some platforms, the set cursor may not be visible unless the window also +-- has input focus. +setCursor :: Window -> Cursor -> IO () +setCursor (Window wptr) (Cursor cptr) = c'glfwSetCursor wptr cptr + +-- | Destroys a cursor previously created with `createCursor`. Any remaining +-- cursors will be destroyed by `terminate`. This function is not +-- . +destroyCursor :: Cursor -> IO () +destroyCursor = c'glfwDestroyCursor . unCursor + +-- | A callback that allows for drag and drop support. +type DropCallback = Window -- ^ The window that received the event. + -> [String] -- ^ The file and/or directory path names + -> IO () + +-- | Sets the file drop callback of the specified window, which is called when +-- one or more dragged files are dropped on the window. +setDropCallback :: Window -> Maybe DropCallback -> IO () +setDropCallback win = setWindowCallback + mk'GLFWdropfun + (\cb w c fs -> do + let count = fromC c + fps <- flip mapM [0..count-1] $ \i -> do + let p = advancePtr fs i + p' <- peek p + peekCString p' + schedule $ cb (fromC w) fps) + (c'glfwSetDropCallback (toC win)) + storedDropFun + win + +-------------------------------------------------------------------------------- +-- Vulkan-related functions +-------------------------------------------------------------------------------- + +-- | This function returns whether the Vulkan loader has been found. +-- This check is performed by `init`. +vulkanSupported :: IO Bool +vulkanSupported = (c'GLFW_TRUE ==) <$> c'glfwVulkanSupported + +-- | Get required vulkan extensions; +-- Pointer memory is managed by GLFW, destroyed by `terminate` call. +-- +-- The returned extension names are kept in `CString` type, because +-- they are expected to be consumed by vulkan device initialization functions. +getRequiredInstanceExtensions :: IO [CString] +getRequiredInstanceExtensions = alloca $ \countPtr -> do + extsPtrPtr <- c'glfwGetRequiredInstanceExtensions countPtr + count <- fromIntegral <$> peek countPtr + peekArray count extsPtrPtr + +-- | Returns the address of the specified Vulkan instance function. +getInstanceProcAddress :: Ptr vkInstance + -- ^ VkInstance. + -- Note, the returned function must be used + -- with the same instance or its child. + -> String + -- ^ Function name + -> IO (FunPtr vkProc) +getInstanceProcAddress i procName + = withCString procName (c'glfwGetInstanceProcAddress i) + +-- | Returns whether the specified queue family can present images. +getPhysicalDevicePresentationSupport :: + Ptr vkInstance + -- ^ VkInstance + -> Ptr vkPhysicalDevice + -- ^ VkPhysicalDevice + -> Word32 + -- ^ Index of a queue family to query. + -- This is an index in the array returned by + -- @vkGetPhysicalDeviceQueueFamilyProperties@ function. + -> IO Bool +getPhysicalDevicePresentationSupport inst dev i + = (c'GLFW_TRUE ==) <$> c'glfwGetPhysicalDevicePresentationSupport inst dev i + +-- | Creates a Vulkan surface for the specified window +createWindowSurface :: Enum vkResult + => Ptr vkInstance + -- ^ VkInstance + -> Window + -- ^ GLFWwindow *window + -> Ptr vkAllocationCallbacks + -- ^ const VkAllocationCallbacks *allocator + -> Ptr vkSurfaceKHR + -- ^ VkSurfaceKHR *surface + -> IO vkResult +createWindowSurface i win acs s + = toEnum . fromIntegral + <$> c'glfwCreateWindowSurface i (toC win) acs s + +-------------------------------------------------------------------------------- +-- Native APIs +-------------------------------------------------------------------------------- + +-- $nativeaccess +-- The low level native-access bindings are exposed here via bindings-GLFW. +-- These must be enabled with the @ExposeNative@ flag passed to bindings-GLFW. +-- The return values of these functions are used as a best-guess and are not +-- coupled with any other implementation. They should be used with caution +-- and at your own risk. + +-- | See +getWin32Adapter :: Window -> IO CString +getWin32Adapter = c'glfwGetWin32Adapter . toC + +-- | See +getWin32Monitor :: Window -> IO CString +getWin32Monitor = c'glfwGetWin32Monitor . toC + +-- | See +getWin32Window :: Window -> IO (Ptr ()) +getWin32Window = c'glfwGetWin32Window . toC + +-- | See +getWGLContext :: Window -> IO (Ptr ()) +getWGLContext = c'glfwGetWGLContext . toC + +-- | See +getCocoaMonitor :: Window -> IO (Ptr Word32) +getCocoaMonitor = c'glfwGetCocoaMonitor . toC + +-- | See +getCocoaWindow :: Window -> IO (Ptr ()) +getCocoaWindow = c'glfwGetCocoaWindow . toC + +-- | See +getNSGLContext :: Window -> IO (Ptr ()) +getNSGLContext = c'glfwGetNSGLContext . toC + +-- | See +getX11Display :: IO (Ptr display) +getX11Display = c'glfwGetX11Display + +-- | See +getX11Adapter :: Window -> IO Word64 +getX11Adapter = c'glfwGetX11Adapter . toC + +-- | See +getX11Monitor :: Window -> IO Word64 +getX11Monitor = c'glfwGetX11Monitor . toC + +-- | See +getX11Window :: Window -> IO Word64 +getX11Window = c'glfwGetX11Window . toC + +-- | See +getX11SelectionString :: IO String +getX11SelectionString = c'glfwGetX11SelectionString >>= peekCString + +-- | See +setX11SelectionString :: String -> IO () +setX11SelectionString = flip withCString c'glfwSetX11SelectionString + +-- | See +getGLXContext :: Window -> IO (Ptr ()) +getGLXContext = c'glfwGetGLXContext . toC + +-- | See +getGLXWindow :: Window -> IO Word64 +getGLXWindow = c'glfwGetGLXWindow . toC + +-- | See +getWaylandDisplay :: IO (Ptr wl_display) +getWaylandDisplay = c'glfwGetWaylandDisplay + +-- | See +getWaylandMonitor :: Window -> IO (Ptr wl_output) +getWaylandMonitor = c'glfwGetWaylandMonitor . toC + +-- | See +getWaylandWindow :: Window -> IO (Ptr wl_surface) +getWaylandWindow = c'glfwGetWaylandWindow . toC + +-- | See +getEGLDisplay :: IO (Ptr ()) +getEGLDisplay = c'glfwGetEGLDisplay + +-- | See +getEGLContext :: Window -> IO (Ptr ()) +getEGLContext = c'glfwGetEGLContext . toC + +-- | See +getEGLSurface :: Window -> IO (Ptr ()) +getEGLSurface = c'glfwGetEGLSurface . toC + +-- | See +getOSMesaContext :: Window -> IO (Ptr ()) +getOSMesaContext = c'glfwGetOSMesaContext . toC + +-- | An RGBA type is a low-dynamic range representation of a color, represented +-- by a 32-bit value. The channels here are in order: R, G, B, A +type OSMesaRGBA = (Word8, Word8, Word8, Word8) + +-- | A color buffer is a two dimensional array of RGBA values. The first +-- dimension is width, and the second is height. +-- +-- TODO: It's a shame this is an Array and not a UArray. +type OSMesaColorBuffer = Array (Int, Int) OSMesaRGBA + +-- | A depth buffer is a two dimensional array of depth values. The range is +-- usually determined by a parameter returned from the query function. +type OSMesaDepthBuffer = Array (Int, Int) Word32 + +-- | Returns the color buffer of the offscreen context provided by OSMesa. The +-- color buffer is returned as an array whose integers are unsigned and +-- represent the (R, G, B, A) values. For formats that do not have alpha, A +-- will always be 255. +getOSMesaColorBuffer :: Window -> IO (Maybe OSMesaColorBuffer) +getOSMesaColorBuffer win = + alloca $ \p'width -> + alloca $ \p'height -> + alloca $ \p'format -> + alloca $ \p'buf -> do + result <- fromC <$> c'glfwGetOSMesaColorBuffer (toC win) + p'width p'height p'format p'buf + if not result then return Nothing else do + w <- fromIntegral <$> peek p'width + h <- fromIntegral <$> peek p'height + format <- peek p'format + buf <- peek p'buf + Just . array ((0, 0), (w, h)) <$> sequence + [ fmap (\rgba -> ((x, y), rgba)) $ + mkRGBA format (castPtr buf) (y * w + x) + | x <- [0..w] + , y <- [0..h] + ] + where + getByte :: Int -> Word32 -> Word8 + getByte i x = fromIntegral $ (x `shiftR` (i * 8)) .&. 0xFF + + mkRGBA :: CInt -> Ptr Word8 -> Int -> IO OSMesaRGBA + mkRGBA 0x1908 buf offset = do + -- OSMESA_RGBA + (rgba :: Word32) <- peekElemOff (castPtr buf) offset + return (getByte 0 rgba, getByte 1 rgba, getByte 2 rgba, getByte 3 rgba) + mkRGBA 0x1 buf offset = do + -- OSMESA_BGRA + (bgra :: Word32) <- peekElemOff (castPtr buf) offset + return (getByte 2 bgra, getByte 1 bgra, getByte 0 bgra, getByte 3 bgra) + mkRGBA 0x2 buf offset = do + -- OSMESA_ARGB + (argb :: Word32) <- peekElemOff (castPtr buf) offset + return (getByte 1 argb, getByte 2 argb, getByte 3 argb, getByte 0 argb) + mkRGBA 0x1907 buf offset = do + -- OSMESA_RGB + r <- peek (buf `plusPtr` (offset * 3 + 0)) + g <- peek (buf `plusPtr` (offset * 3 + 1)) + b <- peek (buf `plusPtr` (offset * 3 + 2)) + return (r, g, b, 255) + mkRGBA 0x4 buf offset = do + -- OSMESA_BGR + b <- peek (buf `plusPtr` (offset * 3 + 0)) + g <- peek (buf `plusPtr` (offset * 3 + 1)) + r <- peek (buf `plusPtr` (offset * 3 + 2)) + return (r, g, b, 255) + mkRGBA 0x5 buf offset = do + -- OSMESA_RGB_565 + (rgb :: Word16) <- peekElemOff (castPtr buf) offset + return ( + fromIntegral $ rgb .&. 0x1F, + fromIntegral $ (rgb `shiftR` 5) .&. 0x3F, + fromIntegral $ (rgb `shiftR` 11) .&. 0x1F, + 255) + mkRGBA fmt _ _ = error $ "Unrecognized OSMESA_FORMAT: " ++ show fmt + +-- | Returns the depth buffer and maximum depth value of the offscreen render +-- target that's provided by OSMesa. +getOSMesaDepthBuffer :: Window -> IO (Maybe (OSMesaDepthBuffer, Word32)) +getOSMesaDepthBuffer win = + alloca $ \p'width -> + alloca $ \p'height -> + alloca $ \p'bytesPerVal -> + alloca $ \p'buf -> do + result <- fromC <$> c'glfwGetOSMesaDepthBuffer (toC win) + p'width p'height p'bytesPerVal p'buf + if not result then return Nothing else do + w <- fromIntegral <$> peek p'width + h <- fromIntegral <$> peek p'height + bytesPerVal <- fromIntegral <$> peek p'bytesPerVal + buf <- peek p'buf + depthBuffer <- array ((0, 0), (w, h)) <$> sequence + [ fmap (\d -> ((x, y), d)) $ + mkDepth bytesPerVal (castPtr buf) (y * w + x) + | x <- [0..w] + , y <- [0..h] + ] + return (Just (depthBuffer, (1 `shiftL` (8 * bytesPerVal)) - 1)) + where + mkDepth :: Int -> Ptr Word8 -> Int -> IO Word32 + mkDepth bpv ptr offset = do + -- Assumes little-endian? + bytes <- forM [0..(bpv - 1)] $ \i -> peekElemOff ptr (offset * bpv + i) + return $ foldl' (\d -> ((d `shiftL` 8) .|.) . fromIntegral) 0 bytes + diff --git a/Graphics/UI/GLFW/C.hs b/Graphics/UI/GLFW/C.hs --- a/Graphics/UI/GLFW/C.hs +++ b/Graphics/UI/GLFW/C.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} -------------------------------------------------------------------------------- @@ -26,6 +26,13 @@ -------------------------------------------------------------------------------- +instance (C CInt b) => C CInt (Maybe b) where + fromC i | i == c'GLFW_DONT_CARE = Nothing + | otherwise = Just $ fromC i + toC = maybe c'GLFW_DONT_CARE toC + +-------------------------------------------------------------------------------- + instance C CInt Char where fromC = chr . fromIntegral toC = fromIntegral . ord @@ -64,10 +71,12 @@ instance C CInt ModifierKeys where fromC v = ModifierKeys - { modifierKeysShift = (v .&. c'GLFW_MOD_SHIFT) /= 0 - , modifierKeysControl = (v .&. c'GLFW_MOD_CONTROL) /= 0 - , modifierKeysAlt = (v .&. c'GLFW_MOD_ALT) /= 0 - , modifierKeysSuper = (v .&. c'GLFW_MOD_SUPER) /= 0 + { modifierKeysShift = (v .&. c'GLFW_MOD_SHIFT) /= 0 + , modifierKeysControl = (v .&. c'GLFW_MOD_CONTROL) /= 0 + , modifierKeysAlt = (v .&. c'GLFW_MOD_ALT) /= 0 + , modifierKeysSuper = (v .&. c'GLFW_MOD_SUPER) /= 0 + , modifierKeysCapsLock = (v .&. c'GLFW_MOD_CAPS_LOCK) /= 0 + , modifierKeysNumLock = (v .&. c'GLFW_MOD_NUM_LOCK) /= 0 } toC = undefined @@ -130,29 +139,23 @@ toC Error'PlatformError = c'GLFW_PLATFORM_ERROR toC Error'FormatUnavailable = c'GLFW_FORMAT_UNAVAILABLE -instance C CInt MonitorState where - fromC v - | v == c'GLFW_TRUE = MonitorState'Connected - | v == c'GLFW_FALSE = MonitorState'Disconnected - | otherwise = error $ "C CInt MonitorState fromC: " ++ show v - toC MonitorState'Connected = c'GLFW_TRUE - toC MonitorState'Disconnected = c'GLFW_FALSE - -instance C CInt FocusState where +instance C CInt InitHint where fromC v - | v == c'GLFW_TRUE = FocusState'Focused - | v == c'GLFW_FALSE = FocusState'Defocused - | otherwise = error $ "C CInt FocusState fromC: " ++ show v - toC FocusState'Focused = c'GLFW_TRUE - toC FocusState'Defocused = c'GLFW_FALSE + | v == c'GLFW_JOYSTICK_HAT_BUTTONS = InitHint'JoystickHatButtons + | v == c'GLFW_COCOA_CHDIR_RESOURCES = InitHint'CocoaChdirResources + | v == c'GLFW_COCOA_MENUBAR = InitHint'CocoaMenubar + | otherwise = error $ "C CInt InitHint fromC: " ++ show v + toC InitHint'JoystickHatButtons = c'GLFW_JOYSTICK_HAT_BUTTONS + toC InitHint'CocoaChdirResources = c'GLFW_COCOA_CHDIR_RESOURCES + toC InitHint'CocoaMenubar = c'GLFW_COCOA_MENUBAR -instance C CInt IconifyState where +instance C CInt MonitorState where fromC v - | v == c'GLFW_TRUE = IconifyState'Iconified - | v == c'GLFW_FALSE = IconifyState'NotIconified - | otherwise = error $ "C CInt IconifyState fromC: " ++ show v - toC IconifyState'Iconified = c'GLFW_TRUE - toC IconifyState'NotIconified = c'GLFW_FALSE + | v == c'GLFW_CONNECTED = MonitorState'Connected + | v == c'GLFW_DISCONNECTED = MonitorState'Disconnected + | otherwise = error $ "C CInt MonitorState fromC: " ++ show v + toC MonitorState'Connected = c'GLFW_CONNECTED + toC MonitorState'Disconnected = c'GLFW_DISCONNECTED instance C CInt ContextRobustness where fromC v @@ -164,6 +167,16 @@ toC ContextRobustness'NoResetNotification = c'GLFW_NO_RESET_NOTIFICATION toC ContextRobustness'LoseContextOnReset = c'GLFW_LOSE_CONTEXT_ON_RESET +instance C CInt ContextReleaseBehavior where + fromC v + | v == c'GLFW_ANY_RELEASE_BEHAVIOR = ContextReleaseBehavior'Any + | v == c'GLFW_RELEASE_BEHAVIOR_NONE = ContextReleaseBehavior'None + | v == c'GLFW_RELEASE_BEHAVIOR_FLUSH = ContextReleaseBehavior'Flush + | otherwise = error $ "C CInt ContextReleaseBehavior fromC: " ++ show v + toC ContextReleaseBehavior'Any = c'GLFW_ANY_RELEASE_BEHAVIOR + toC ContextReleaseBehavior'None = c'GLFW_RELEASE_BEHAVIOR_NONE + toC ContextReleaseBehavior'Flush = c'GLFW_RELEASE_BEHAVIOR_FLUSH + instance C CInt OpenGLProfile where fromC v | v == c'GLFW_OPENGL_ANY_PROFILE = OpenGLProfile'Any @@ -176,12 +189,24 @@ instance C CInt ClientAPI where fromC v + | v == c'GLFW_NO_API = ClientAPI'NoAPI | v == c'GLFW_OPENGL_API = ClientAPI'OpenGL | v == c'GLFW_OPENGL_ES_API = ClientAPI'OpenGLES | otherwise = error $ "C CInt ClientAPI fromC: " ++ show v + toC ClientAPI'NoAPI = c'GLFW_NO_API toC ClientAPI'OpenGL = c'GLFW_OPENGL_API toC ClientAPI'OpenGLES = c'GLFW_OPENGL_ES_API +instance C CInt ContextCreationAPI where + fromC v + | v == c'GLFW_NATIVE_CONTEXT_API = ContextCreationAPI'Native + | v == c'GLFW_EGL_CONTEXT_API = ContextCreationAPI'EGL + | v == c'GLFW_OSMESA_CONTEXT_API = ContextCreationAPI'OSMesa + | otherwise = error $ "C CInt ContextCreationAPI fromC: " ++ show v + toC ContextCreationAPI'Native = c'GLFW_NATIVE_CONTEXT_API + toC ContextCreationAPI'EGL = c'GLFW_EGL_CONTEXT_API + toC ContextCreationAPI'OSMesa = c'GLFW_OSMESA_CONTEXT_API + instance C CInt Key where fromC v | v == c'GLFW_KEY_UNKNOWN = Key'Unknown @@ -474,6 +499,28 @@ toC Joystick'15 = c'GLFW_JOYSTICK_15 toC Joystick'16 = c'GLFW_JOYSTICK_16 +instance C CUChar JoystickHatState where + fromC v + | v == c'GLFW_HAT_CENTERED = JoystickHatState'Centered + | v == c'GLFW_HAT_UP = JoystickHatState'Up + | v == c'GLFW_HAT_RIGHT = JoystickHatState'Right + | v == c'GLFW_HAT_DOWN = JoystickHatState'Down + | v == c'GLFW_HAT_LEFT = JoystickHatState'Left + | v == c'GLFW_HAT_RIGHT_UP = JoystickHatState'RightUp + | v == c'GLFW_HAT_RIGHT_DOWN = JoystickHatState'RightDown + | v == c'GLFW_HAT_LEFT_UP = JoystickHatState'LeftUp + | v == c'GLFW_HAT_LEFT_DOWN = JoystickHatState'LeftDown + | otherwise = error $ "C CUChar JoystickHatState fromC: " ++ show v + toC JoystickHatState'Centered = c'GLFW_HAT_CENTERED + toC JoystickHatState'Up = c'GLFW_HAT_UP + toC JoystickHatState'Right = c'GLFW_HAT_RIGHT + toC JoystickHatState'Down = c'GLFW_HAT_DOWN + toC JoystickHatState'Left = c'GLFW_HAT_LEFT + toC JoystickHatState'RightUp = c'GLFW_HAT_RIGHT_UP + toC JoystickHatState'RightDown = c'GLFW_HAT_RIGHT_DOWN + toC JoystickHatState'LeftUp = c'GLFW_HAT_LEFT_UP + toC JoystickHatState'LeftDown = c'GLFW_HAT_LEFT_DOWN + instance C CUChar JoystickButtonState where fromC v | v == c'GLFW_PRESS = JoystickButtonState'Pressed @@ -482,6 +529,80 @@ toC JoystickButtonState'Pressed = c'GLFW_PRESS toC JoystickButtonState'Released = c'GLFW_RELEASE +instance C CInt JoystickState where + fromC v + | v == c'GLFW_CONNECTED = JoystickState'Connected + | v == c'GLFW_DISCONNECTED = JoystickState'Disconnected + | otherwise = error $ "C CInt JoystickState fromC: " ++ show v + toC JoystickState'Connected = c'GLFW_CONNECTED + toC JoystickState'Disconnected = c'GLFW_DISCONNECTED + +instance C CInt GamepadButton where + fromC v + | v == c'GLFW_GAMEPAD_BUTTON_A = GamepadButton'A + | v == c'GLFW_GAMEPAD_BUTTON_B = GamepadButton'B + | v == c'GLFW_GAMEPAD_BUTTON_X = GamepadButton'X + | v == c'GLFW_GAMEPAD_BUTTON_Y = GamepadButton'Y + | v == c'GLFW_GAMEPAD_BUTTON_LEFT_BUMPER = GamepadButton'LeftBumper + | v == c'GLFW_GAMEPAD_BUTTON_RIGHT_BUMPER = GamepadButton'RightBumper + | v == c'GLFW_GAMEPAD_BUTTON_BACK = GamepadButton'Back + | v == c'GLFW_GAMEPAD_BUTTON_START = GamepadButton'Start + | v == c'GLFW_GAMEPAD_BUTTON_GUIDE = GamepadButton'Guide + | v == c'GLFW_GAMEPAD_BUTTON_LEFT_THUMB = GamepadButton'LeftThumb + | v == c'GLFW_GAMEPAD_BUTTON_RIGHT_THUMB = GamepadButton'RightThumb + | v == c'GLFW_GAMEPAD_BUTTON_DPAD_UP = GamepadButton'DpadUp + | v == c'GLFW_GAMEPAD_BUTTON_DPAD_RIGHT = GamepadButton'DpadRight + | v == c'GLFW_GAMEPAD_BUTTON_DPAD_DOWN = GamepadButton'DpadDown + | v == c'GLFW_GAMEPAD_BUTTON_DPAD_LEFT = GamepadButton'DpadLeft + | v == c'GLFW_GAMEPAD_BUTTON_CROSS = GamepadButton'Cross + | v == c'GLFW_GAMEPAD_BUTTON_CIRCLE = GamepadButton'Circle + | v == c'GLFW_GAMEPAD_BUTTON_SQUARE = GamepadButton'Square + | v == c'GLFW_GAMEPAD_BUTTON_TRIANGLE = GamepadButton'Triangle + | otherwise = error $ "C CInt GamepadButton fromC: " ++ show v + toC GamepadButton'A = c'GLFW_GAMEPAD_BUTTON_A + toC GamepadButton'B = c'GLFW_GAMEPAD_BUTTON_B + toC GamepadButton'X = c'GLFW_GAMEPAD_BUTTON_X + toC GamepadButton'Y = c'GLFW_GAMEPAD_BUTTON_Y + toC GamepadButton'LeftBumper = c'GLFW_GAMEPAD_BUTTON_LEFT_BUMPER + toC GamepadButton'RightBumper = c'GLFW_GAMEPAD_BUTTON_RIGHT_BUMPER + toC GamepadButton'Back = c'GLFW_GAMEPAD_BUTTON_BACK + toC GamepadButton'Start = c'GLFW_GAMEPAD_BUTTON_START + toC GamepadButton'Guide = c'GLFW_GAMEPAD_BUTTON_GUIDE + toC GamepadButton'LeftThumb = c'GLFW_GAMEPAD_BUTTON_LEFT_THUMB + toC GamepadButton'RightThumb = c'GLFW_GAMEPAD_BUTTON_RIGHT_THUMB + toC GamepadButton'DpadUp = c'GLFW_GAMEPAD_BUTTON_DPAD_UP + toC GamepadButton'DpadRight = c'GLFW_GAMEPAD_BUTTON_DPAD_RIGHT + toC GamepadButton'DpadDown = c'GLFW_GAMEPAD_BUTTON_DPAD_DOWN + toC GamepadButton'DpadLeft = c'GLFW_GAMEPAD_BUTTON_DPAD_LEFT + toC GamepadButton'Cross = c'GLFW_GAMEPAD_BUTTON_CROSS + toC GamepadButton'Circle = c'GLFW_GAMEPAD_BUTTON_CIRCLE + toC GamepadButton'Square = c'GLFW_GAMEPAD_BUTTON_SQUARE + toC GamepadButton'Triangle = c'GLFW_GAMEPAD_BUTTON_TRIANGLE + +instance C CUChar GamepadButtonState where + fromC v + | v == c'GLFW_PRESS = GamepadButtonState'Pressed + | v == c'GLFW_RELEASE = GamepadButtonState'Released + | otherwise = error $ "C CUChar GamepadButtonState fromC: " ++ show v + toC GamepadButtonState'Pressed = c'GLFW_PRESS + toC GamepadButtonState'Released = c'GLFW_RELEASE + +instance C CInt GamepadAxis where + fromC v + | v == c'GLFW_GAMEPAD_AXIS_LEFT_X = GamepadAxis'LeftX + | v == c'GLFW_GAMEPAD_AXIS_RIGHT_X = GamepadAxis'RightX + | v == c'GLFW_GAMEPAD_AXIS_LEFT_Y = GamepadAxis'LeftY + | v == c'GLFW_GAMEPAD_AXIS_RIGHT_Y = GamepadAxis'RightY + | v == c'GLFW_GAMEPAD_AXIS_LEFT_TRIGGER = GamepadAxis'LeftTrigger + | v == c'GLFW_GAMEPAD_AXIS_RIGHT_TRIGGER = GamepadAxis'RightTrigger + | otherwise = error $ "C CInt GamepadAxis fromC: " ++ show v + toC GamepadAxis'LeftX = c'GLFW_GAMEPAD_AXIS_LEFT_X + toC GamepadAxis'RightX = c'GLFW_GAMEPAD_AXIS_RIGHT_X + toC GamepadAxis'LeftY = c'GLFW_GAMEPAD_AXIS_LEFT_Y + toC GamepadAxis'RightY = c'GLFW_GAMEPAD_AXIS_RIGHT_Y + toC GamepadAxis'LeftTrigger = c'GLFW_GAMEPAD_AXIS_LEFT_TRIGGER + toC GamepadAxis'RightTrigger = c'GLFW_GAMEPAD_AXIS_RIGHT_TRIGGER + instance C CInt MouseButton where fromC v | v == c'GLFW_MOUSE_BUTTON_1 = MouseButton'1 @@ -543,6 +664,22 @@ | otherwise = error $ "C CInt StickyMouseButtonsInputMode fromC: " ++ show v toC StickyMouseButtonsInputMode'Enabled = c'GLFW_TRUE toC StickyMouseButtonsInputMode'Disabled = c'GLFW_FALSE + +instance C CInt WindowAttrib where + fromC v + | v == c'GLFW_DECORATED = WindowAttrib'Decorated + | v == c'GLFW_RESIZABLE = WindowAttrib'Resizable + | v == c'GLFW_FLOATING = WindowAttrib'Floating + | v == c'GLFW_AUTO_ICONIFY = WindowAttrib'AutoIconify + | v == c'GLFW_FOCUS_ON_SHOW = WindowAttrib'FocusOnShow + | v == c'GLFW_HOVERED = WindowAttrib'Hovered + | otherwise = error $ "C CInt WindowAttrib fromC: " ++ show v + toC WindowAttrib'Decorated = c'GLFW_DECORATED + toC WindowAttrib'Resizable = c'GLFW_RESIZABLE + toC WindowAttrib'Floating = c'GLFW_FLOATING + toC WindowAttrib'AutoIconify = c'GLFW_AUTO_ICONIFY + toC WindowAttrib'FocusOnShow = c'GLFW_FOCUS_ON_SHOW + toC WindowAttrib'Hovered = c'GLFW_HOVERED -------------------------------------------------------------------------------- diff --git a/Graphics/UI/GLFW/Types.hs b/Graphics/UI/GLFW/Types.hs --- a/Graphics/UI/GLFW/Types.hs +++ b/Graphics/UI/GLFW/Types.hs @@ -13,6 +13,7 @@ import Data.Data (Data) import Data.IORef (IORef) import Data.Typeable (Typeable) +import Data.Word (Word8) import Foreign.Ptr (Ptr) import Foreign.C.Types (CUChar(..)) import GHC.Generics @@ -22,17 +23,17 @@ -------------------------------------------------------------------------------- -- Error handling --- | An enum for one of the . +-- | An enum for one of the . data Error = - Error'NotInitialized -- ^ - | Error'NoCurrentContext -- ^ - | Error'InvalidEnum -- ^ - | Error'InvalidValue -- ^ - | Error'OutOfMemory -- ^ - | Error'ApiUnavailable -- ^ - | Error'VersionUnavailable -- ^ - | Error'PlatformError -- ^ - | Error'FormatUnavailable -- ^ + Error'NotInitialized -- ^ + | Error'NoCurrentContext -- ^ + | Error'InvalidEnum -- ^ + | Error'InvalidValue -- ^ + | Error'OutOfMemory -- ^ + | Error'ApiUnavailable -- ^ + | Error'VersionUnavailable -- ^ + | Error'PlatformError -- ^ + | Error'FormatUnavailable -- ^ deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) instance NFData Error @@ -40,12 +41,23 @@ -------------------------------------------------------------------------------- -- Initialization and version information +-- | Initialization hints are set before glfwInit and affect how the library +-- behaves until termination. Hints are set with glfwInitHint. See +-- +data InitHint + = InitHint'JoystickHatButtons + | InitHint'CocoaChdirResources + | InitHint'CocoaMenubar + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData InitHint + -- | The library version of the GLFW implementation in use. --- See +-- See data Version = Version - { versionMajor :: Int - , versionMinor :: Int - , versionRevision :: Int + { versionMajor :: {-# UNPACK #-} !Int + , versionMinor :: {-# UNPACK #-} !Int + , versionRevision :: {-# UNPACK #-} !Int } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) instance NFData Version @@ -54,12 +66,13 @@ -- Monitor handling -- | Represents a physical monitor that's currently connected. --- See the +-- See the newtype Monitor = Monitor { unMonitor :: Ptr C'GLFWmonitor } deriving (Data, Eq, Ord, Show, Typeable, Generic) --- | Part of the 'MonitorCallback', for when a monitor gets connected or disconnected. +-- | Part of the t'Graphics.UI.GLFW.MonitorCallback', for when a monitor gets +-- connected or disconnected. data MonitorState = MonitorState'Connected | MonitorState'Disconnected @@ -67,20 +80,20 @@ instance NFData MonitorState --- | See +-- | See data VideoMode = VideoMode - { videoModeWidth :: Int - , videoModeHeight :: Int - , videoModeRedBits :: Int - , videoModeGreenBits :: Int - , videoModeBlueBits :: Int - , videoModeRefreshRate :: Int + { videoModeWidth :: {-# UNPACK #-} !Int + , videoModeHeight :: {-# UNPACK #-} !Int + , videoModeRedBits :: {-# UNPACK #-} !Int + , videoModeGreenBits :: {-# UNPACK #-} !Int + , videoModeBlueBits :: {-# UNPACK #-} !Int + , videoModeRefreshRate :: {-# UNPACK #-} !Int } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) instance NFData VideoMode -- | Lets you adjust the gamma of a monitor. To ensure that only valid values are created, use 'makeGammaRamp'. --- See . +-- See . data GammaRamp = GammaRamp -- NOTE: It would be bad to give clients a way to construct invalid gamma ramps -- with lists of unequal length, so this constructor should not be exported. @@ -108,76 +121,93 @@ -- | Collects all the callbacks that can be associated with a Window into a single place. data WindowCallbacks = WindowCallbacks - { storedCharFun :: IORef C'GLFWcharfun - , storedCursorEnterFun :: IORef C'GLFWcursorenterfun - , storedCursorPosFun :: IORef C'GLFWcursorposfun - , storedFramebufferSizeFun :: IORef C'GLFWframebuffersizefun - , storedKeyFun :: IORef C'GLFWkeyfun - , storedMouseButtonFun :: IORef C'GLFWmousebuttonfun - , storedScrollFun :: IORef C'GLFWscrollfun - , storedWindowCloseFun :: IORef C'GLFWwindowclosefun - , storedWindowFocusFun :: IORef C'GLFWwindowfocusfun - , storedWindowIconifyFun :: IORef C'GLFWwindowiconifyfun - , storedWindowPosFun :: IORef C'GLFWwindowposfun - , storedWindowRefreshFun :: IORef C'GLFWwindowrefreshfun - , storedWindowSizeFun :: IORef C'GLFWwindowsizefun - , storedDropFun :: IORef C'GLFWdropfun + { storedCharFun :: !(IORef C'GLFWcharfun) + , storedCharModsFun :: !(IORef C'GLFWcharmodsfun) + , storedCursorEnterFun :: !(IORef C'GLFWcursorenterfun) + , storedCursorPosFun :: !(IORef C'GLFWcursorposfun) + , storedFramebufferSizeFun :: !(IORef C'GLFWframebuffersizefun) + , storedKeyFun :: !(IORef C'GLFWkeyfun) + , storedMouseButtonFun :: !(IORef C'GLFWmousebuttonfun) + , storedScrollFun :: !(IORef C'GLFWscrollfun) + , storedWindowCloseFun :: !(IORef C'GLFWwindowclosefun) + , storedWindowFocusFun :: !(IORef C'GLFWwindowfocusfun) + , storedWindowIconifyFun :: !(IORef C'GLFWwindowiconifyfun) + , storedWindowPosFun :: !(IORef C'GLFWwindowposfun) + , storedWindowRefreshFun :: !(IORef C'GLFWwindowrefreshfun) + , storedWindowSizeFun :: !(IORef C'GLFWwindowsizefun) + , storedWindowContentScaleFun :: !(IORef C'GLFWwindowcontentscalefun) + , storedWindowMaximizeFun :: !(IORef C'GLFWwindowmaximizefun) + , storedDropFun :: !(IORef C'GLFWdropfun) } --- | Reprisents a GLFW window value. --- See the +-- | Represents a GLFW window value. +-- See the newtype Window = Window { unWindow :: Ptr C'GLFWwindow } deriving (Data, Eq, Ord, Show, Typeable, Generic) -- | Lets you set various window hints before creating a 'Window'. --- See , --- particularly . +-- See , +-- particularly . data WindowHint = - WindowHint'Resizable Bool - | WindowHint'Visible Bool - | WindowHint'Decorated Bool - | WindowHint'RedBits Int - | WindowHint'GreenBits Int - | WindowHint'BlueBits Int - | WindowHint'AlphaBits Int - | WindowHint'DepthBits Int - | WindowHint'StencilBits Int - | WindowHint'AccumRedBits Int - | WindowHint'AccumGreenBits Int - | WindowHint'AccumBlueBits Int - | WindowHint'AccumAlphaBits Int - | WindowHint'AuxBuffers Int - | WindowHint'Samples Int - | WindowHint'RefreshRate Int - | WindowHint'Stereo Bool - | WindowHint'sRGBCapable Bool - | WindowHint'ClientAPI ClientAPI - | WindowHint'ContextVersionMajor Int - | WindowHint'ContextVersionMinor Int - | WindowHint'ContextRobustness ContextRobustness - | WindowHint'OpenGLForwardCompat Bool - | WindowHint'OpenGLDebugContext Bool - | WindowHint'OpenGLProfile OpenGLProfile + WindowHint'Resizable !Bool + | WindowHint'Visible !Bool + | WindowHint'Decorated !Bool + | WindowHint'RedBits !(Maybe Int) + | WindowHint'GreenBits !(Maybe Int) + | WindowHint'BlueBits !(Maybe Int) + | WindowHint'AlphaBits !(Maybe Int) + | WindowHint'DepthBits !(Maybe Int) + | WindowHint'StencilBits !(Maybe Int) + | WindowHint'AccumRedBits !(Maybe Int) + | WindowHint'AccumGreenBits !(Maybe Int) + | WindowHint'AccumBlueBits !(Maybe Int) + | WindowHint'AccumAlphaBits !(Maybe Int) + | WindowHint'AuxBuffers !(Maybe Int) + | WindowHint'Samples !(Maybe Int) + | WindowHint'RefreshRate !(Maybe Int) + | WindowHint'DoubleBuffer !Bool + | WindowHint'Stereo !Bool + | WindowHint'sRGBCapable !Bool + | WindowHint'Floating !Bool + | WindowHint'Focused !Bool + | WindowHint'Maximized !Bool + | WindowHint'AutoIconify !Bool + | WindowHint'ClientAPI !ClientAPI + | WindowHint'ContextCreationAPI !ContextCreationAPI + | WindowHint'ContextVersionMajor {-# UNPACK #-} !Int + | WindowHint'ContextVersionMinor {-# UNPACK #-} !Int + | WindowHint'ContextRobustness !ContextRobustness + | WindowHint'ContextReleaseBehavior !ContextReleaseBehavior + | WindowHint'ContextNoError !Bool + | WindowHint'OpenGLForwardCompat !Bool + | WindowHint'OpenGLDebugContext !Bool + | WindowHint'OpenGLProfile !OpenGLProfile + | WindowHint'TransparentFramebuffer !Bool + | WindowHint'CenterCursor !Bool + | WindowHint'FocusOnShow !Bool + | WindowHint'ScaleToMonitor !Bool + | WindowHint'CocoaRetinaFramebuffer !Bool + | WindowHint'CocoaGraphicsSwitching !Bool + | WindowHint'CocoaFrameName !String + | WindowHint'X11ClassName !String + | WindowHint'X11InstanceName !String deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) instance NFData WindowHint --- | For use with the focus callback. -data FocusState = - FocusState'Focused - | FocusState'Defocused - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData FocusState - --- | For use with the iconify callback. (note: iconified means minimized) -data IconifyState = - IconifyState'Iconified - | IconifyState'NotIconified +-- | A window-specific attribute. +-- See +data WindowAttrib + = WindowAttrib'Decorated + | WindowAttrib'Resizable + | WindowAttrib'Floating + | WindowAttrib'AutoIconify + | WindowAttrib'FocusOnShow + | WindowAttrib'Hovered deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) -instance NFData IconifyState +instance NFData WindowAttrib -- | The OpenGL robustness strategy. data ContextRobustness = @@ -199,16 +229,48 @@ -- | The type of OpenGL to create a context for. data ClientAPI = - ClientAPI'OpenGL + ClientAPI'NoAPI + | ClientAPI'OpenGL | ClientAPI'OpenGLES deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) instance NFData ClientAPI +-- | The type of API to use for context creation. +-- See the for +-- more information. +-- +-- This is a hard constraint. If no client API is requested, this hint is +-- ignored. Best practice is to stick to one API or the other, otherwise may +-- segfault on Linux. OS X does not support the EGL API and will fail if this +-- hint is used. +data ContextCreationAPI + = ContextCreationAPI'Native + | ContextCreationAPI'EGL + | ContextCreationAPI'OSMesa + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData ContextCreationAPI + +-- | The context release behavior. +-- See the for +-- more information. +-- +-- Context release behaviors are described in detail by the +-- +-- extension. +data ContextReleaseBehavior + = ContextReleaseBehavior'Any + | ContextReleaseBehavior'None + | ContextReleaseBehavior'Flush + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData ContextReleaseBehavior + -------------------------------------------------------------------------------- -- Input handling --- | Part of the system. +-- | Part of the system. data Key = Key'Unknown | Key'Space @@ -335,7 +397,7 @@ instance NFData Key --- | The state of an individual key when 'getKey' is called. +-- | The state of an individual key when 'Graphics.UI.GLFW.getKey' is called. data KeyState = KeyState'Pressed | KeyState'Released @@ -344,7 +406,7 @@ instance NFData KeyState --- | For use with the system. +-- | For use with the system. data Joystick = Joystick'1 | Joystick'2 @@ -366,7 +428,8 @@ instance NFData Joystick --- | If a given joystick button is pressed or not when 'getJoystickButtons' is called. +-- | If a given joystick button is pressed or not when +-- 'Graphics.UI.GLFW.getJoystickButtons' is called. data JoystickButtonState = JoystickButtonState'Pressed | JoystickButtonState'Released @@ -374,7 +437,33 @@ instance NFData JoystickButtonState --- | Part of the system. +-- | Part of the t'Graphics.UI.GLFW.JoystickCallback', for when a monitor gets +-- connected or disconnected. +data JoystickState + = JoystickState'Connected + | JoystickState'Disconnected + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData JoystickState + +-- | The valid hat states of a joystick. Part of the +-- +-- system. +data JoystickHatState + = JoystickHatState'Centered + | JoystickHatState'Up + | JoystickHatState'Right + | JoystickHatState'Down + | JoystickHatState'Left + | JoystickHatState'RightUp + | JoystickHatState'RightDown + | JoystickHatState'LeftUp + | JoystickHatState'LeftDown + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData JoystickHatState + +-- | Part of the system. data MouseButton = MouseButton'1 | MouseButton'2 @@ -388,7 +477,8 @@ instance NFData MouseButton --- | If the mouse button is pressed or not when 'getMouseButton' is called. +-- | If the mouse button is pressed or not when 'Graphics.UI.GLFW.getMouseButton' is +-- called. data MouseButtonState = MouseButtonState'Pressed | MouseButtonState'Released @@ -405,7 +495,7 @@ instance NFData CursorState -- | Allows for special forms of mouse input. --- See +-- See data CursorInputMode = CursorInputMode'Normal | CursorInputMode'Hidden @@ -415,11 +505,11 @@ instance NFData CursorInputMode -- | When sticky keys is enabled, once a key is pressed it will remain pressed --- at least until the state is polled with 'getKey'. After that, if the key has --- been released it will switch back to released. This helps prevent problems --- with low-resolution polling missing key pressed. Note that use of the --- callbacks to avoid this problem the the recommended route, and this is just --- for a fallback. +-- at least until the state is polled with 'Graphics.UI.GLFW.getKey'. After +-- that, if the key has been released it will switch back to released. This +-- helps prevent problems with low-resolution polling missing key pressed. Note +-- that use of the callbacks to avoid this problem the the recommended route, +-- and this is just for a fallback. data StickyKeysInputMode = StickyKeysInputMode'Enabled | StickyKeysInputMode'Disabled @@ -437,37 +527,110 @@ -- | Modifier keys that were pressed as part of another keypress event. data ModifierKeys = ModifierKeys - { modifierKeysShift :: Bool - , modifierKeysControl :: Bool - , modifierKeysAlt :: Bool - , modifierKeysSuper :: Bool + { modifierKeysShift :: !Bool + , modifierKeysControl :: !Bool + , modifierKeysAlt :: !Bool + , modifierKeysSuper :: !Bool + , modifierKeysCapsLock :: !Bool + , modifierKeysNumLock :: !Bool } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) instance NFData ModifierKeys --------------------------------------------------------------------------------- --- 3.1 Additions --------------------------------------------------------------------------------- +-- | The different types of buttons we can find on a Gamepad. +data GamepadButton + = GamepadButton'A + | GamepadButton'B + | GamepadButton'X + | GamepadButton'Y + | GamepadButton'LeftBumper + | GamepadButton'RightBumper + | GamepadButton'Back + | GamepadButton'Start + | GamepadButton'Guide + | GamepadButton'LeftThumb + | GamepadButton'RightThumb + | GamepadButton'DpadUp + | GamepadButton'DpadRight + | GamepadButton'DpadDown + | GamepadButton'DpadLeft + | GamepadButton'Cross + | GamepadButton'Circle + | GamepadButton'Square + | GamepadButton'Triangle + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) +instance NFData GamepadButton + +-- | The states in which the gamepad buttons are found +data GamepadButtonState + = GamepadButtonState'Pressed + | GamepadButtonState'Released + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData GamepadButtonState + +-- | The different axes along which we can measure continuous input on a Gamepad +data GamepadAxis + = GamepadAxis'LeftX + | GamepadAxis'LeftY + | GamepadAxis'RightX + | GamepadAxis'RightY + | GamepadAxis'LeftTrigger + | GamepadAxis'RightTrigger + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData GamepadAxis + +-- | This describes the input state of a gamepad +data GamepadState = GamepadState + { getButtonState :: GamepadButton -> GamepadButtonState + -- ^ Returns the current state of the given button + , getAxisState :: GamepadAxis -> Float + -- ^ Returns a value in the range [-1.0, 1.0] for the + -- given game axis + } deriving (Typeable, Generic) + +instance Eq GamepadState where + a == b = + let compareSt f x = (&& (f a x == f b x)) + in foldr (compareSt getButtonState) True [minBound..maxBound] && + foldr (compareSt getAxisState) True [minBound..maxBound] + +instance NFData GamepadState + deriving instance Data CUChar -- | GLFW image data, for setting up custom mouse cursor appearnaces. data Image = Image - { imageWidth :: Int - , imageHeight :: Int + { imageWidth :: {-# UNPACK #-} !Int + , imageHeight :: {-# UNPACK #-} !Int , imagePixels :: [CUChar] } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) +-- | Create an image given the function to generate 8-bit RGBA values based on +-- the pixel location. +mkImage :: Int -> Int -> (Int -> Int -> (Word8, Word8, Word8, Word8)) -> Image +mkImage width height gen = Image + { imageWidth = width + , imageHeight = height + , imagePixels = [ CUChar channel | y <- [0..(height - 1)] + , x <- [0..(width - 1)] + , let (r, g, b, a) = gen x y + , channel <- [r, g, b, a] + ] + } + instance NFData Image --- | Reprisents a GLFW cursor. +-- | Represents a GLFW cursor. newtype Cursor = Cursor { unCursor :: Ptr C'GLFWcursor } deriving (Data, Eq, Ord, Show, Typeable, Generic) -- | Lets you use one of the standard cursor appearnaces that the local -- system theme provides for. --- See . +-- See . data StandardCursorShape = StandardCursorShape'Arrow | StandardCursorShape'IBeam diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ creating windows with OpenGL contexts and managing input and events. GLFW-b depends on [bindings-GLFW][3], which, as of the time of this writing, -binds to GLFW 3.1, [released 2015-01-18][4]. +binds to GLFW 3.3, [released 2019-04-15][4]. For a demonstration of GLFW-b, see [GLFW-b-demo][5]. @@ -39,6 +39,6 @@ [1]: http://www.haskell.org/ [2]: http://www.glfw.org/ [3]: https://github.com/bsl/bindings-GLFW -[4]: http://www.glfw.org/Version-3.1-released.html +[4]: http://www.glfw.org/Version-3.3-released.html [5]: https://github.com/bsl/GLFW-b-demo [6]: http://nvie.com/posts/a-successful-git-branching-model/ diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -14,6 +14,3 @@ getPressedKeys? getJoystickAxesN? - -Coordinate with GLFW C-library maintainer about new functionality. -1.) waitEvents with timeout? diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,7 +1,10 @@ -- base import Control.Concurrent (threadDelay) +import Control.Monad (forM_) import Data.Char (isAscii) +import Data.Bits (xor) import Data.List (intercalate, isPrefixOf) +import Data.Maybe (isNothing) -- HUnit import Test.HUnit ((@?=), assertBool, assertFailure) @@ -22,14 +25,20 @@ GLFW.setErrorCallback $ Just $ \e s -> putStrLn $ unwords ["###", show e, show s] + GLFW.initHint GLFW.InitHint'CocoaChdirResources False True <- GLFW.init Just mon <- GLFW.getPrimaryMonitor GLFW.windowHint $ GLFW.WindowHint'Visible False + GLFW.windowHint $ GLFW.WindowHint'CocoaFrameName "GLFW-b test" mwin@(Just win) <- GLFW.createWindow 100 100 "GLFW-b test" Nothing Nothing GLFW.makeContextCurrent mwin + -- Mostly check for compiling + GLFW.setJoystickCallback $ Just $ \j c -> putStrLn $ concat + [ show j, " changed state: ", show c ] + defaultMain $ tests mon win -- TODO because of how defaultMain works, this code is not reached @@ -38,12 +47,13 @@ -------------------------------------------------------------------------------- -versionMajor, versionMinor :: Int +versionMajor, versionMinor, versionRevision :: Int versionMajor = 3 -versionMinor = 1 +versionMinor = 3 +versionRevision = 9 giveItTime :: IO () -giveItTime = threadDelay 250000 +giveItTime = threadDelay 500000 joysticks :: [GLFW.Joystick] joysticks = @@ -80,68 +90,94 @@ -------------------------------------------------------------------------------- +glfwTest :: String -> IO () -> Test +glfwTest name test = testCase name $ do + GLFW.clearError + test + err <- GLFW.getError + case err of + Nothing -> return () + Just e -> assertFailure $ + concat ["Test '", name, "' generated error: ", show e] + tests :: GLFW.Monitor -> GLFW.Window -> [Test] tests mon win = [ testGroup "Initialization and version information" [ testCase "getVersion" test_getVersion , testCase "getVersionString" test_getVersionString + , testCase "getError" test_getError ] , testGroup "Monitor handling" - [ testCase "getMonitors" test_getMonitors - , testCase "getPrimaryMonitor" test_getPrimaryMonitor - , testCase "getMonitorPos" $ test_getMonitorPos mon - , testCase "getMonitorPhysicalSize" $ test_getMonitorPhysicalSize mon - , testCase "getMonitorName" $ test_getMonitorName mon - , testCase "getVideoModes" $ test_getVideoModes mon - , testCase "getVideoMode" $ test_getVideoMode mon - , testCase "getGamma" $ test_getGammaRamp mon - -- , testCase "setGamma" $ test_setGamma mon - -- , testCase "gamma ramp" $ test_gamma_ramp mon + [ glfwTest "getMonitors" test_getMonitors + , glfwTest "getPrimaryMonitor" test_getPrimaryMonitor + , glfwTest "getMonitorPos" $ test_getMonitorPos mon + , glfwTest "getMonitorPhysicalSize" $ test_getMonitorPhysicalSize mon + , glfwTest "getMonitorWorkarea" $ test_getMonitorWorkarea mon + , glfwTest "getMonitorName" $ test_getMonitorName mon + , glfwTest "getVideoModes" $ test_getVideoModes mon + , glfwTest "getVideoMode" $ test_getVideoMode mon + , glfwTest "getGamma" $ test_getGammaRamp mon ] , testGroup "Window handling" - [ testCase "defaultWindowHints" test_defaultWindowHints - , testCase "window close flag" $ test_window_close_flag win - , testCase "setWindowTitle" $ test_setWindowTitle win - , testCase "window pos" $ test_window_pos win - , testCase "window size" $ test_window_size win - , testCase "getFramebufferSize" $ test_getFramebufferSize win - , testCase "iconification" $ test_iconification win - -- , testCase "show/hide" $ test_show_hide win - , testCase "getWindowMonitor" $ test_getWindowMonitor win mon - , testCase "cursor pos" $ test_cursor_pos win - , testCase "getWindowFocused" $ test_getWindowFocused win - , testCase "getWindowResizable" $ test_getWindowResizable win - , testCase "getWindowDecorated" $ test_getWindowDecorated win - , testCase "getWindowClientAPI" $ test_getWindowClientAPI win - , testCase "window context version" $ test_window_context_version win - , testCase "getWindowContextRobustness" $ test_getWindowContextRobustness win - , testCase "getWindowOpenGLForwardCompat" $ test_getWindowOpenGLForwardCompat win - , testCase "getWindowOpenGLDebugContext" $ test_getWindowOpenGLDebugContext win - , testCase "getWindowOpenGLProfile" $ test_getWindowOpenGLProfile win - , testCase "pollEvents" test_pollEvents - , testCase "waitEvents" test_waitEvents + [ glfwTest "defaultWindowHints" test_defaultWindowHints + + -- Test window attributes + , glfwTest "getWindowFocused" $ test_getWindowFocused win + , glfwTest "getWindowResizable" $ test_getWindowResizable win + , glfwTest "getWindowDecorated" $ test_getWindowDecorated win + , glfwTest "getWindowClientAPI" $ test_getWindowClientAPI win + , glfwTest "window context version" $ test_window_context_version win + , glfwTest "getWindowContextRobustness" $ test_getWindowContextRobustness win + , glfwTest "getWindowOpenGLForwardCompat" $ test_getWindowOpenGLForwardCompat win + , glfwTest "getWindowOpenGLDebugContext" $ test_getWindowOpenGLDebugContext win + , glfwTest "getWindowOpenGLProfile" $ test_getWindowOpenGLProfile win + , glfwTest "window attribs" $ test_windowAttribs win + , glfwTest "window close flag" $ test_window_close_flag win + , glfwTest "setWindowOpacity" $ test_window_opacity win + , glfwTest "setWindowTitle" $ test_setWindowTitle win + , glfwTest "window pos" $ test_window_pos win + , glfwTest "window size" $ test_window_size win + , glfwTest "getWindowFrameSize" $ test_getWindowFrameSize win + , glfwTest "getFramebufferSize" $ test_getFramebufferSize win + , glfwTest "iconification" $ test_iconification win + -- , glfwTest "show/hide" $ test_show_hide win + , glfwTest "getWindowMonitor" $ test_getWindowMonitor win mon + , glfwTest "setWindowed" $ test_setWindowed win + , glfwTest "setWindowIcon" $ test_setWindowIcon win + , glfwTest "maximizeWindow" $ test_maximizeWindow win + , glfwTest "setWindowSizeLimits" $ test_setWindowSizeLimits win + , glfwTest "setWindowAspectRatio" $ test_setWindowAspectRatio win + , glfwTest "focusWindow" $ test_focusWindow win + , glfwTest "cursor pos" $ test_cursor_pos win + , glfwTest "pollEvents" test_pollEvents + , glfwTest "waitEvents" test_waitEvents + , glfwTest "waitEventsTimeout" test_waitEventsTimeout ] , testGroup "Input handling" - [ testCase "cursor input mode" $ test_cursor_input_mode win - , testCase "sticky keys input mode" $ test_sticky_keys_input_mode win - , testCase "sticky mouse buttons input mode" $ test_sticky_mouse_buttons_input_mode win - , testCase "joystickPresent" test_joystickPresent - , testCase "getJoystickAxes" test_getJoystickAxes - , testCase "getJoystickButtons" test_getJoystickButtons - , testCase "getJoystickName" test_getJoystickName + [ glfwTest "cursor input mode" $ test_cursor_input_mode win + , glfwTest "sticky keys input mode" $ test_sticky_keys_input_mode win + , glfwTest "sticky mouse buttons input mode" $ test_sticky_mouse_buttons_input_mode win + , glfwTest "joystickPresent" test_joystickPresent + , glfwTest "getJoystickAxes" test_getJoystickAxes + , glfwTest "getJoystickButtons" test_getJoystickButtons + , glfwTest "getJoystickName" test_getJoystickName + , glfwTest "getKeyName" test_getKeyName + , glfwTest "getGamepadState" test_getGamepadState ] , testGroup "Time" - [ testCase "getTime" test_getTime - , testCase "setTime" test_setTime + [ glfwTest "getTime" test_getTime + , glfwTest "setTime" test_setTime + , glfwTest "getTimerValue" test_getTimerValue + , glfwTest "getTimerFrequency" test_getTimerFrequency ] , testGroup "Context" - [ testCase "getCurrentContext" $ test_getCurrentContext win - , testCase "swapBuffers" $ test_swapBuffers win - , testCase "swapInterval" test_swapInterval - , testCase "extensionSupported" test_extensionSupported + [ glfwTest "getCurrentContext" $ test_getCurrentContext win + , glfwTest "swapBuffers" $ test_swapBuffers win + , glfwTest "swapInterval" test_swapInterval + , glfwTest "extensionSupported" test_extensionSupported ] , testGroup "Clipboard" - [ testCase "clipboard" $ test_clipboard win + [ glfwTest "clipboard" $ test_clipboard win ] ] @@ -152,6 +188,7 @@ v <- GLFW.getVersion GLFW.versionMajor v @?= versionMajor GLFW.versionMinor v @?= versionMinor + GLFW.versionRevision v @?= versionRevision test_getVersionString :: IO () test_getVersionString = do @@ -162,6 +199,9 @@ where v = intercalate "." $ map show [versionMajor, versionMinor] +test_getError :: IO () +test_getError = GLFW.getError >>= assertBool "Got GLFW error!" . isNothing + test_getMonitors :: IO () test_getMonitors = do r <- GLFW.getMonitors @@ -188,14 +228,20 @@ assertBool "" $ w `between` (0, 1000) assertBool "" $ h `between` (0, 500) +test_getMonitorWorkarea :: GLFW.Monitor -> IO () +test_getMonitorWorkarea mon = do + (x, y, w, h) <- GLFW.getMonitorWorkarea mon + assertBool "workarea x nonnegative" $ x >= 0 + assertBool "workarea y nonnegative" $ y >= 0 + assertBool "workarea width positive" $ w > 0 + assertBool "workarea height positive" $ h > 0 + test_getMonitorName :: GLFW.Monitor -> IO () test_getMonitorName mon = do mname <- GLFW.getMonitorName mon case mname of Nothing -> assertFailure "" - Just name -> do - assertBool "" $ length name `between` (0, 20) - assertBool "" $ all isAscii name + Just name -> assertBool "" $ all isAscii name test_getVideoModes :: GLFW.Monitor -> IO () test_getVideoModes mon = do @@ -228,6 +274,19 @@ test_defaultWindowHints = GLFW.defaultWindowHints +test_windowAttribs :: GLFW.Window -> IO () +test_windowAttribs win = do + oldRsz <- GLFW.getWindowAttrib win GLFW.WindowAttrib'Resizable + + GLFW.setWindowAttrib win GLFW.WindowAttrib'Resizable False + GLFW.getWindowAttrib win GLFW.WindowAttrib'Resizable >>= (@?= False) + + GLFW.setWindowAttrib win GLFW.WindowAttrib'Resizable True + rsz <- GLFW.getWindowAttrib win GLFW.WindowAttrib'Resizable + rsz @?= True + + GLFW.setWindowAttrib win GLFW.WindowAttrib'Resizable oldRsz + test_window_close_flag :: GLFW.Window -> IO () test_window_close_flag win = do r0 <- GLFW.windowShouldClose win @@ -241,6 +300,17 @@ r2 <- GLFW.windowShouldClose win r2 @?= False +test_window_opacity :: GLFW.Window -> IO () +test_window_opacity win = do + oldOpacity <- GLFW.getWindowOpacity win + + GLFW.setWindowOpacity win 0.27 + opacity <- GLFW.getWindowOpacity win + assertBool "Opacity is close to what we set it to." $ + (abs (opacity - 0.27)) < 0.01 + + GLFW.setWindowOpacity win oldOpacity + test_setWindowTitle :: GLFW.Window -> IO () test_setWindowTitle win = GLFW.setWindowTitle win "some new title" @@ -270,14 +340,22 @@ test_window_size :: GLFW.Window -> IO () test_window_size win = do - let w = 17 - h = 37 + let w = 170 + h = 370 GLFW.setWindowSize win w h giveItTime (w', h') <- GLFW.getWindowSize win w' @?= w h' @?= h +test_getWindowFrameSize :: GLFW.Window -> IO () +test_getWindowFrameSize win = do + -- The frame size is pretty dependent on the window manager. We can only + -- really expect that the window has a title bar, so the top frame won't be + -- zero... + (_, t, _, _) <- GLFW.getWindowFrameSize win + assertBool "Window has no frame width up top!" $ t > 0 + test_getFramebufferSize :: GLFW.Window -> IO () test_getFramebufferSize win = do (w, h) <- GLFW.getWindowSize win @@ -293,15 +371,17 @@ test_iconification :: GLFW.Window -> IO () test_iconification win = do + GLFW.showWindow win is0 <- GLFW.getWindowIconified win - is0 @?= GLFW.IconifyState'NotIconified + is0 @?= False GLFW.iconifyWindow win giveItTime is1 <- GLFW.getWindowIconified win - is1 @?= GLFW.IconifyState'Iconified + is1 @?= True GLFW.restoreWindow win + GLFW.hideWindow win -- test_show_hide :: GLFW.Window -> IO () -- test_show_hide win = do @@ -323,23 +403,77 @@ m <- GLFW.getWindowMonitor win m @?= Nothing +test_setWindowed :: GLFW.Window -> IO () +test_setWindowed win = GLFW.setWindowed win 100 100 0 0 + +test_setWindowIcon :: GLFW.Window -> IO () +test_setWindowIcon win = let + icon1 = GLFW.mkImage 32 32 $ \x y -> + case even ((x `div` 8) `xor` (y `div` 8)) of + True -> (255, 0, 0, 255) + False -> (0, 255, 0, 255) + + icon2 = GLFW.mkImage 16 16 $ \x y -> + case even ((x `div` 8) `xor` (y `div` 8)) of + True -> (255, 255, 255, 255) + False -> (0, 0, 0, 255) + + in GLFW.setWindowIcon win [icon1, icon2] + +test_maximizeWindow :: GLFW.Window -> IO () +test_maximizeWindow win = do + GLFW.showWindow win + startsMaximized <- GLFW.getWindowMaximized win + startsMaximized @?= False + + GLFW.maximizeWindow win + giveItTime + + isMaximized <- GLFW.getWindowMaximized win + isMaximized @?= True + GLFW.hideWindow win + +test_setWindowSizeLimits :: GLFW.Window -> IO () +test_setWindowSizeLimits win = do + GLFW.setWindowSizeLimits win (Just 640) (Just 480) (Just 1024) (Just 768) + +test_setWindowAspectRatio :: GLFW.Window -> IO () +test_setWindowAspectRatio win = do + GLFW.setWindowAspectRatio win Nothing + +test_focusWindow :: GLFW.Window -> IO () +test_focusWindow = GLFW.focusWindow + test_cursor_pos :: GLFW.Window -> IO () test_cursor_pos win = do - (w, h) <- GLFW.getWindowSize win - let cx = fromIntegral w / 2 - cy = fromIntegral h / 2 - -- Can you set the cursor pos as of glfw 3.1? I don't see it in the - -- docs. - GLFW.setCursorPos win cx cy - --giveItTime - --(cx', cy') <- GLFW.getCursorPos win - --cx' @?= cx - --cy' @?= cy + GLFW.showWindow win + (w, h) <- GLFW.getWindowSize win + -- Make sure we use integral coordinates here so that we don't run into + -- platform-dependent differences. + let cx :: Double + cy :: Double + (cx, cy) = (fromIntegral $ w `div` 2, fromIntegral $ h `div` 2) + + -- !HACK! Poll events seems to be necessary on OS X, + -- before /and/ after glfwSetCursorPos, otherwise, the + -- windowing system likely never receives the cursor update. This is + -- reflected in the C version of GLFW as well, we just call it here in + -- order to have a more robust test. + + GLFW.pollEvents + GLFW.setCursorPos win cx cy + GLFW.pollEvents -- !HACK! see comment above + + (cx', cy') <- GLFW.getCursorPos win + cx' @?= cx + cy' @?= cy + GLFW.hideWindow win + test_getWindowFocused :: GLFW.Window -> IO () test_getWindowFocused win = do fs <- GLFW.getWindowFocused win - fs @?= GLFW.FocusState'Defocused + fs @?= False test_getWindowResizable :: GLFW.Window -> IO () test_getWindowResizable win = do @@ -360,8 +494,7 @@ test_window_context_version win = do v0 <- GLFW.getWindowContextVersionMajor win v1 <- GLFW.getWindowContextVersionMinor win - v2 <- GLFW.getWindowContextVersionRevision win - assertBool "" $ all (`between` (0, 20)) [v0, v1, v2] + assertBool "" $ all (`between` (0, 20)) [v0, v1] test_getWindowContextRobustness :: GLFW.Window -> IO () test_getWindowContextRobustness win = do @@ -388,9 +521,13 @@ GLFW.pollEvents test_waitEvents :: IO () -test_waitEvents = - GLFW.waitEvents +test_waitEvents = GLFW.postEmptyEvent >> GLFW.waitEvents +test_waitEventsTimeout :: IO () +test_waitEventsTimeout = + -- to not slow down the test too much we set the timeout to 0.001 second : + GLFW.waitEventsTimeout 0.001 + -------------------------------------------------------------------------------- test_cursor_input_mode :: GLFW.Window -> IO () @@ -451,6 +588,27 @@ test_getJoystickName = mapM_ GLFW.getJoystickName joysticks +test_getKeyName :: IO () +test_getKeyName = + forM_ (zip [GLFW.Key'Slash, GLFW.Key'Period] ["/", "."]) $ \(k, n) -> do + name <- GLFW.getKeyName k 0 + case name of + Nothing -> return () + Just s -> s @?= n + +test_getGamepadState :: IO () +test_getGamepadState = + forM_ joysticks $ \js -> do + mst <- GLFW.getGamepadState js + case mst of + (Just st) -> do + GLFW.joystickIsGamepad js >>= assertBool "Is gamepad" + GLFW.getGamepadName js >>= assertBool "Gamepad has name" . not . null + forM_ [minBound..maxBound] $ assertBool "Button not pressed" + . (== GLFW.GamepadButtonState'Released) + . GLFW.getButtonState st + _ -> return () + -------------------------------------------------------------------------------- test_getTime :: IO () @@ -469,6 +627,12 @@ Just t' -> assertBool "" $ t' `between` (t, t+10) Nothing -> assertFailure "" +test_getTimerValue :: IO () +test_getTimerValue = GLFW.getTimerValue >>= assertBool "" . (> 0) + +test_getTimerFrequency :: IO () +test_getTimerFrequency = GLFW.getTimerFrequency >>= assertBool "" . (> 0) + -------------------------------------------------------------------------------- test_getCurrentContext :: GLFW.Window -> IO () @@ -506,7 +670,13 @@ ] setGet s = do GLFW.setClipboardString win s - GLFW.getClipboardString win + giveItTime + result <- GLFW.getClipboardString win + + err <- GLFW.getError + return $ case err of + Just (GLFW.Error'FormatUnavailable, _) -> Just s + _ -> result --------------------------------------------------------------------------------