diff --git a/GLFW-b.cabal b/GLFW-b.cabal --- a/GLFW-b.cabal +++ b/GLFW-b.cabal @@ -1,91 +1,90 @@ -name: GLFW-b -version: 3.3.0.0 -category: Graphics - -author: Brian Lewis -maintainer: Brian Lewis - , Schell Scivally - , Pavel Krajcevski - -license: BSD3 -license-file: LICENSE - -synopsis: Bindings to GLFW OpenGL library -description: - Bindings to GLFW (), an open source, multi-platform - library for creating windows with OpenGL contexts and managing input and - events. - . - GLFW-b depends on bindings-GLFW - (), which, as of the time - of this writing, binds to GLFW 3.3.0, released 2019-04-15 - ( - ). - . - If you've used GLFW < 3 before, you should read the transition guide - (). - -cabal-version: >= 1.10 -build-type: Simple - --------------------------------------------------------------------------------- - -extra-source-files: - README.md - TODO - --------------------------------------------------------------------------------- - -library - default-language: Haskell2010 - - ghc-options: -Wall - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs - - exposed-modules: - Graphics.UI.GLFW - - other-modules: - Graphics.UI.GLFW.C - Graphics.UI.GLFW.Types - - build-depends: - base < 5 - , deepseq >= 1.1.0.0 - , array >= 0.5.3.0 - , bindings-GLFW >= 3.3.0.0 - --------------------------------------------------------------------------------- - -test-suite main - default-language: Haskell2010 - - ghc-options: -Wall - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs - - type: exitcode-stdio-1.0 - - main-is: Test.hs - - other-modules: - Graphics.UI.GLFW - Graphics.UI.GLFW.C - Graphics.UI.GLFW.Types - - build-depends: - GLFW-b - , HUnit >= 1.3 && < 1.7 - , base < 5 - , array >= 0.5.3.0 - , bindings-GLFW >= 3.3.0.0 - , deepseq >= 1.1.0.0 - , test-framework == 0.8.* - , test-framework-hunit == 0.3.* - --------------------------------------------------------------------------------- - -source-repository head - type: git - location: git://github.com/bsl/GLFW-b.git +name: GLFW-b +version: 3.3.9.0 +category: Graphics + +author: Brian Lewis +maintainer: Brian Lewis + , Schell Scivally + , Pavel Krajcevski + +license: BSD3 +license-file: LICENSE + +synopsis: Bindings to GLFW OpenGL library +description: + Bindings to GLFW (), an open source, multi-platform + library for creating windows with OpenGL contexts and managing input and + events. + . + GLFW-b depends on bindings-GLFW + (), which, as of the time + 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 + (). + +cabal-version: >= 1.10 +build-type: Simple + +-------------------------------------------------------------------------------- + +extra-source-files: + README.md + TODO + +-------------------------------------------------------------------------------- + +library + default-language: Haskell2010 + + ghc-options: -Wall + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + + exposed-modules: + Graphics.UI.GLFW + Graphics.UI.GLFW.C + + other-modules: + Graphics.UI.GLFW.Types + + build-depends: + base < 5 + , deepseq >= 1.1.0.0 + , array >= 0.5.3.0 + , bindings-GLFW >= 3.3.9.1 + +-------------------------------------------------------------------------------- + +test-suite main + default-language: Haskell2010 + + ghc-options: -Wall + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + + type: exitcode-stdio-1.0 + + main-is: Test.hs + + other-modules: + Graphics.UI.GLFW + Graphics.UI.GLFW.Types + + build-depends: + GLFW-b + , HUnit >= 1.3 && < 1.7 + , base < 5 + , array >= 0.5.3.0 + , bindings-GLFW >= 3.3.9.1 + , deepseq >= 1.1.0.0 + , test-framework == 0.8.* + , test-framework-hunit == 0.3.* + +-------------------------------------------------------------------------------- + +source-repository head + type: git + location: git://github.com/bsl/GLFW-b.git diff --git a/Graphics/UI/GLFW.hs b/Graphics/UI/GLFW.hs --- a/Graphics/UI/GLFW.hs +++ b/Graphics/UI/GLFW.hs @@ -1,2067 +1,2067 @@ -{-# 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 c'a new window. (toC x) --- 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 :: Window -> IO (Ptr display) -getX11Display = c'glfwGetX11Display . toC - --- | 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 +{-# 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 :: Window -> IO (Ptr display) +getX11Display = c'glfwGetX11Display . toC + +-- | 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,686 +1,686 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} - --------------------------------------------------------------------------------- - --- This code is generated by util/genC.hs. - --------------------------------------------------------------------------------- - -module Graphics.UI.GLFW.C where - --------------------------------------------------------------------------------- - -import Data.Bits ((.&.)) -import Data.Char (chr, ord) -import Foreign.C.Types (CDouble, CFloat, CInt, CUChar, CUInt, CUShort) -import Foreign.Ptr (Ptr) - -import Bindings.GLFW -import Graphics.UI.GLFW.Types - --------------------------------------------------------------------------------- - -class C c h where - fromC :: c -> h - toC :: h -> c - --------------------------------------------------------------------------------- - -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 - -instance C CUInt Char where - fromC = chr . fromIntegral - toC = fromIntegral . ord - -instance C CDouble Double where - fromC = realToFrac - toC = realToFrac - -instance C CInt Int where - fromC = fromIntegral - toC = fromIntegral - -instance C CUInt Int where - fromC = fromIntegral - toC = fromIntegral - -instance C CUShort Int where - fromC = fromIntegral - toC = fromIntegral - -instance C CFloat Double where - fromC = realToFrac - toC = realToFrac - -instance C (Ptr C'GLFWmonitor) Monitor where - fromC = Monitor - toC = unMonitor - -instance C (Ptr C'GLFWwindow) Window where - fromC = Window - toC = unWindow - -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 - , modifierKeysCapsLock = (v .&. c'GLFW_MOD_CAPS_LOCK) /= 0 - , modifierKeysNumLock = (v .&. c'GLFW_MOD_NUM_LOCK) /= 0 - } - toC = undefined - -instance C C'GLFWvidmode VideoMode where - fromC gvm = VideoMode - { videoModeWidth = fromIntegral $ c'GLFWvidmode'width gvm - , videoModeHeight = fromIntegral $ c'GLFWvidmode'height gvm - , videoModeRedBits = fromIntegral $ c'GLFWvidmode'redBits gvm - , videoModeGreenBits = fromIntegral $ c'GLFWvidmode'greenBits gvm - , videoModeBlueBits = fromIntegral $ c'GLFWvidmode'blueBits gvm - , videoModeRefreshRate = fromIntegral $ c'GLFWvidmode'refreshRate gvm - } - toC = undefined - -instance C CInt StandardCursorShape where - fromC v - | v == c'GLFW_ARROW_CURSOR = StandardCursorShape'Arrow - | v == c'GLFW_IBEAM_CURSOR = StandardCursorShape'IBeam - | v == c'GLFW_CROSSHAIR_CURSOR = StandardCursorShape'Crosshair - | v == c'GLFW_HAND_CURSOR = StandardCursorShape'Hand - | v == c'GLFW_HRESIZE_CURSOR = StandardCursorShape'HResize - | v == c'GLFW_VRESIZE_CURSOR = StandardCursorShape'VResize - | otherwise = error $ "C CInt StandardCursorShape fromC: " ++ show v - toC StandardCursorShape'Arrow = c'GLFW_ARROW_CURSOR - toC StandardCursorShape'IBeam = c'GLFW_IBEAM_CURSOR - toC StandardCursorShape'Crosshair = c'GLFW_CROSSHAIR_CURSOR - toC StandardCursorShape'Hand = c'GLFW_HAND_CURSOR - toC StandardCursorShape'HResize = c'GLFW_HRESIZE_CURSOR - toC StandardCursorShape'VResize = c'GLFW_VRESIZE_CURSOR - --------------------------------------------------------------------------------- - -instance C CInt Bool where - fromC v - | v == c'GLFW_FALSE = False - | v == c'GLFW_TRUE = True - | otherwise = error $ "C CInt Bool fromC: " ++ show v - toC False = c'GLFW_FALSE - toC True = c'GLFW_TRUE - -instance C CInt Error where - fromC v - | v == c'GLFW_NOT_INITIALIZED = Error'NotInitialized - | v == c'GLFW_NO_CURRENT_CONTEXT = Error'NoCurrentContext - | v == c'GLFW_INVALID_ENUM = Error'InvalidEnum - | v == c'GLFW_INVALID_VALUE = Error'InvalidValue - | v == c'GLFW_OUT_OF_MEMORY = Error'OutOfMemory - | v == c'GLFW_API_UNAVAILABLE = Error'ApiUnavailable - | v == c'GLFW_VERSION_UNAVAILABLE = Error'VersionUnavailable - | v == c'GLFW_PLATFORM_ERROR = Error'PlatformError - | v == c'GLFW_FORMAT_UNAVAILABLE = Error'FormatUnavailable - | otherwise = error $ "C CInt Error fromC: " ++ show v - toC Error'NotInitialized = c'GLFW_NOT_INITIALIZED - toC Error'NoCurrentContext = c'GLFW_NO_CURRENT_CONTEXT - toC Error'InvalidEnum = c'GLFW_INVALID_ENUM - toC Error'InvalidValue = c'GLFW_INVALID_VALUE - toC Error'OutOfMemory = c'GLFW_OUT_OF_MEMORY - toC Error'ApiUnavailable = c'GLFW_API_UNAVAILABLE - toC Error'VersionUnavailable = c'GLFW_VERSION_UNAVAILABLE - toC Error'PlatformError = c'GLFW_PLATFORM_ERROR - toC Error'FormatUnavailable = c'GLFW_FORMAT_UNAVAILABLE - -instance C CInt InitHint where - fromC v - | 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 MonitorState where - fromC v - | 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 - | v == c'GLFW_NO_ROBUSTNESS = ContextRobustness'NoRobustness - | v == c'GLFW_NO_RESET_NOTIFICATION = ContextRobustness'NoResetNotification - | v == c'GLFW_LOSE_CONTEXT_ON_RESET = ContextRobustness'LoseContextOnReset - | otherwise = error $ "C CInt ContextRobustness fromC: " ++ show v - toC ContextRobustness'NoRobustness = c'GLFW_NO_ROBUSTNESS - 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 - | v == c'GLFW_OPENGL_COMPAT_PROFILE = OpenGLProfile'Compat - | v == c'GLFW_OPENGL_CORE_PROFILE = OpenGLProfile'Core - | otherwise = error $ "C CInt OpenGLProfile fromC: " ++ show v - toC OpenGLProfile'Any = c'GLFW_OPENGL_ANY_PROFILE - toC OpenGLProfile'Compat = c'GLFW_OPENGL_COMPAT_PROFILE - toC OpenGLProfile'Core = c'GLFW_OPENGL_CORE_PROFILE - -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 - | v == c'GLFW_KEY_SPACE = Key'Space - | v == c'GLFW_KEY_APOSTROPHE = Key'Apostrophe - | v == c'GLFW_KEY_COMMA = Key'Comma - | v == c'GLFW_KEY_MINUS = Key'Minus - | v == c'GLFW_KEY_PERIOD = Key'Period - | v == c'GLFW_KEY_SLASH = Key'Slash - | v == c'GLFW_KEY_0 = Key'0 - | v == c'GLFW_KEY_1 = Key'1 - | v == c'GLFW_KEY_2 = Key'2 - | v == c'GLFW_KEY_3 = Key'3 - | v == c'GLFW_KEY_4 = Key'4 - | v == c'GLFW_KEY_5 = Key'5 - | v == c'GLFW_KEY_6 = Key'6 - | v == c'GLFW_KEY_7 = Key'7 - | v == c'GLFW_KEY_8 = Key'8 - | v == c'GLFW_KEY_9 = Key'9 - | v == c'GLFW_KEY_SEMICOLON = Key'Semicolon - | v == c'GLFW_KEY_EQUAL = Key'Equal - | v == c'GLFW_KEY_A = Key'A - | v == c'GLFW_KEY_B = Key'B - | v == c'GLFW_KEY_C = Key'C - | v == c'GLFW_KEY_D = Key'D - | v == c'GLFW_KEY_E = Key'E - | v == c'GLFW_KEY_F = Key'F - | v == c'GLFW_KEY_G = Key'G - | v == c'GLFW_KEY_H = Key'H - | v == c'GLFW_KEY_I = Key'I - | v == c'GLFW_KEY_J = Key'J - | v == c'GLFW_KEY_K = Key'K - | v == c'GLFW_KEY_L = Key'L - | v == c'GLFW_KEY_M = Key'M - | v == c'GLFW_KEY_N = Key'N - | v == c'GLFW_KEY_O = Key'O - | v == c'GLFW_KEY_P = Key'P - | v == c'GLFW_KEY_Q = Key'Q - | v == c'GLFW_KEY_R = Key'R - | v == c'GLFW_KEY_S = Key'S - | v == c'GLFW_KEY_T = Key'T - | v == c'GLFW_KEY_U = Key'U - | v == c'GLFW_KEY_V = Key'V - | v == c'GLFW_KEY_W = Key'W - | v == c'GLFW_KEY_X = Key'X - | v == c'GLFW_KEY_Y = Key'Y - | v == c'GLFW_KEY_Z = Key'Z - | v == c'GLFW_KEY_LEFT_BRACKET = Key'LeftBracket - | v == c'GLFW_KEY_BACKSLASH = Key'Backslash - | v == c'GLFW_KEY_RIGHT_BRACKET = Key'RightBracket - | v == c'GLFW_KEY_GRAVE_ACCENT = Key'GraveAccent - | v == c'GLFW_KEY_WORLD_1 = Key'World1 - | v == c'GLFW_KEY_WORLD_2 = Key'World2 - | v == c'GLFW_KEY_ESCAPE = Key'Escape - | v == c'GLFW_KEY_ENTER = Key'Enter - | v == c'GLFW_KEY_TAB = Key'Tab - | v == c'GLFW_KEY_BACKSPACE = Key'Backspace - | v == c'GLFW_KEY_INSERT = Key'Insert - | v == c'GLFW_KEY_DELETE = Key'Delete - | v == c'GLFW_KEY_RIGHT = Key'Right - | v == c'GLFW_KEY_LEFT = Key'Left - | v == c'GLFW_KEY_DOWN = Key'Down - | v == c'GLFW_KEY_UP = Key'Up - | v == c'GLFW_KEY_PAGE_UP = Key'PageUp - | v == c'GLFW_KEY_PAGE_DOWN = Key'PageDown - | v == c'GLFW_KEY_HOME = Key'Home - | v == c'GLFW_KEY_END = Key'End - | v == c'GLFW_KEY_CAPS_LOCK = Key'CapsLock - | v == c'GLFW_KEY_SCROLL_LOCK = Key'ScrollLock - | v == c'GLFW_KEY_NUM_LOCK = Key'NumLock - | v == c'GLFW_KEY_PRINT_SCREEN = Key'PrintScreen - | v == c'GLFW_KEY_PAUSE = Key'Pause - | v == c'GLFW_KEY_F1 = Key'F1 - | v == c'GLFW_KEY_F2 = Key'F2 - | v == c'GLFW_KEY_F3 = Key'F3 - | v == c'GLFW_KEY_F4 = Key'F4 - | v == c'GLFW_KEY_F5 = Key'F5 - | v == c'GLFW_KEY_F6 = Key'F6 - | v == c'GLFW_KEY_F7 = Key'F7 - | v == c'GLFW_KEY_F8 = Key'F8 - | v == c'GLFW_KEY_F9 = Key'F9 - | v == c'GLFW_KEY_F10 = Key'F10 - | v == c'GLFW_KEY_F11 = Key'F11 - | v == c'GLFW_KEY_F12 = Key'F12 - | v == c'GLFW_KEY_F13 = Key'F13 - | v == c'GLFW_KEY_F14 = Key'F14 - | v == c'GLFW_KEY_F15 = Key'F15 - | v == c'GLFW_KEY_F16 = Key'F16 - | v == c'GLFW_KEY_F17 = Key'F17 - | v == c'GLFW_KEY_F18 = Key'F18 - | v == c'GLFW_KEY_F19 = Key'F19 - | v == c'GLFW_KEY_F20 = Key'F20 - | v == c'GLFW_KEY_F21 = Key'F21 - | v == c'GLFW_KEY_F22 = Key'F22 - | v == c'GLFW_KEY_F23 = Key'F23 - | v == c'GLFW_KEY_F24 = Key'F24 - | v == c'GLFW_KEY_F25 = Key'F25 - | v == c'GLFW_KEY_KP_0 = Key'Pad0 - | v == c'GLFW_KEY_KP_1 = Key'Pad1 - | v == c'GLFW_KEY_KP_2 = Key'Pad2 - | v == c'GLFW_KEY_KP_3 = Key'Pad3 - | v == c'GLFW_KEY_KP_4 = Key'Pad4 - | v == c'GLFW_KEY_KP_5 = Key'Pad5 - | v == c'GLFW_KEY_KP_6 = Key'Pad6 - | v == c'GLFW_KEY_KP_7 = Key'Pad7 - | v == c'GLFW_KEY_KP_8 = Key'Pad8 - | v == c'GLFW_KEY_KP_9 = Key'Pad9 - | v == c'GLFW_KEY_KP_DECIMAL = Key'PadDecimal - | v == c'GLFW_KEY_KP_DIVIDE = Key'PadDivide - | v == c'GLFW_KEY_KP_MULTIPLY = Key'PadMultiply - | v == c'GLFW_KEY_KP_SUBTRACT = Key'PadSubtract - | v == c'GLFW_KEY_KP_ADD = Key'PadAdd - | v == c'GLFW_KEY_KP_ENTER = Key'PadEnter - | v == c'GLFW_KEY_KP_EQUAL = Key'PadEqual - | v == c'GLFW_KEY_LEFT_SHIFT = Key'LeftShift - | v == c'GLFW_KEY_LEFT_CONTROL = Key'LeftControl - | v == c'GLFW_KEY_LEFT_ALT = Key'LeftAlt - | v == c'GLFW_KEY_LEFT_SUPER = Key'LeftSuper - | v == c'GLFW_KEY_RIGHT_SHIFT = Key'RightShift - | v == c'GLFW_KEY_RIGHT_CONTROL = Key'RightControl - | v == c'GLFW_KEY_RIGHT_ALT = Key'RightAlt - | v == c'GLFW_KEY_RIGHT_SUPER = Key'RightSuper - | v == c'GLFW_KEY_MENU = Key'Menu - | otherwise = error $ "C CInt Key fromC: " ++ show v - toC Key'Unknown = c'GLFW_KEY_UNKNOWN - toC Key'Space = c'GLFW_KEY_SPACE - toC Key'Apostrophe = c'GLFW_KEY_APOSTROPHE - toC Key'Comma = c'GLFW_KEY_COMMA - toC Key'Minus = c'GLFW_KEY_MINUS - toC Key'Period = c'GLFW_KEY_PERIOD - toC Key'Slash = c'GLFW_KEY_SLASH - toC Key'0 = c'GLFW_KEY_0 - toC Key'1 = c'GLFW_KEY_1 - toC Key'2 = c'GLFW_KEY_2 - toC Key'3 = c'GLFW_KEY_3 - toC Key'4 = c'GLFW_KEY_4 - toC Key'5 = c'GLFW_KEY_5 - toC Key'6 = c'GLFW_KEY_6 - toC Key'7 = c'GLFW_KEY_7 - toC Key'8 = c'GLFW_KEY_8 - toC Key'9 = c'GLFW_KEY_9 - toC Key'Semicolon = c'GLFW_KEY_SEMICOLON - toC Key'Equal = c'GLFW_KEY_EQUAL - toC Key'A = c'GLFW_KEY_A - toC Key'B = c'GLFW_KEY_B - toC Key'C = c'GLFW_KEY_C - toC Key'D = c'GLFW_KEY_D - toC Key'E = c'GLFW_KEY_E - toC Key'F = c'GLFW_KEY_F - toC Key'G = c'GLFW_KEY_G - toC Key'H = c'GLFW_KEY_H - toC Key'I = c'GLFW_KEY_I - toC Key'J = c'GLFW_KEY_J - toC Key'K = c'GLFW_KEY_K - toC Key'L = c'GLFW_KEY_L - toC Key'M = c'GLFW_KEY_M - toC Key'N = c'GLFW_KEY_N - toC Key'O = c'GLFW_KEY_O - toC Key'P = c'GLFW_KEY_P - toC Key'Q = c'GLFW_KEY_Q - toC Key'R = c'GLFW_KEY_R - toC Key'S = c'GLFW_KEY_S - toC Key'T = c'GLFW_KEY_T - toC Key'U = c'GLFW_KEY_U - toC Key'V = c'GLFW_KEY_V - toC Key'W = c'GLFW_KEY_W - toC Key'X = c'GLFW_KEY_X - toC Key'Y = c'GLFW_KEY_Y - toC Key'Z = c'GLFW_KEY_Z - toC Key'LeftBracket = c'GLFW_KEY_LEFT_BRACKET - toC Key'Backslash = c'GLFW_KEY_BACKSLASH - toC Key'RightBracket = c'GLFW_KEY_RIGHT_BRACKET - toC Key'GraveAccent = c'GLFW_KEY_GRAVE_ACCENT - toC Key'World1 = c'GLFW_KEY_WORLD_1 - toC Key'World2 = c'GLFW_KEY_WORLD_2 - toC Key'Escape = c'GLFW_KEY_ESCAPE - toC Key'Enter = c'GLFW_KEY_ENTER - toC Key'Tab = c'GLFW_KEY_TAB - toC Key'Backspace = c'GLFW_KEY_BACKSPACE - toC Key'Insert = c'GLFW_KEY_INSERT - toC Key'Delete = c'GLFW_KEY_DELETE - toC Key'Right = c'GLFW_KEY_RIGHT - toC Key'Left = c'GLFW_KEY_LEFT - toC Key'Down = c'GLFW_KEY_DOWN - toC Key'Up = c'GLFW_KEY_UP - toC Key'PageUp = c'GLFW_KEY_PAGE_UP - toC Key'PageDown = c'GLFW_KEY_PAGE_DOWN - toC Key'Home = c'GLFW_KEY_HOME - toC Key'End = c'GLFW_KEY_END - toC Key'CapsLock = c'GLFW_KEY_CAPS_LOCK - toC Key'ScrollLock = c'GLFW_KEY_SCROLL_LOCK - toC Key'NumLock = c'GLFW_KEY_NUM_LOCK - toC Key'PrintScreen = c'GLFW_KEY_PRINT_SCREEN - toC Key'Pause = c'GLFW_KEY_PAUSE - toC Key'F1 = c'GLFW_KEY_F1 - toC Key'F2 = c'GLFW_KEY_F2 - toC Key'F3 = c'GLFW_KEY_F3 - toC Key'F4 = c'GLFW_KEY_F4 - toC Key'F5 = c'GLFW_KEY_F5 - toC Key'F6 = c'GLFW_KEY_F6 - toC Key'F7 = c'GLFW_KEY_F7 - toC Key'F8 = c'GLFW_KEY_F8 - toC Key'F9 = c'GLFW_KEY_F9 - toC Key'F10 = c'GLFW_KEY_F10 - toC Key'F11 = c'GLFW_KEY_F11 - toC Key'F12 = c'GLFW_KEY_F12 - toC Key'F13 = c'GLFW_KEY_F13 - toC Key'F14 = c'GLFW_KEY_F14 - toC Key'F15 = c'GLFW_KEY_F15 - toC Key'F16 = c'GLFW_KEY_F16 - toC Key'F17 = c'GLFW_KEY_F17 - toC Key'F18 = c'GLFW_KEY_F18 - toC Key'F19 = c'GLFW_KEY_F19 - toC Key'F20 = c'GLFW_KEY_F20 - toC Key'F21 = c'GLFW_KEY_F21 - toC Key'F22 = c'GLFW_KEY_F22 - toC Key'F23 = c'GLFW_KEY_F23 - toC Key'F24 = c'GLFW_KEY_F24 - toC Key'F25 = c'GLFW_KEY_F25 - toC Key'Pad0 = c'GLFW_KEY_KP_0 - toC Key'Pad1 = c'GLFW_KEY_KP_1 - toC Key'Pad2 = c'GLFW_KEY_KP_2 - toC Key'Pad3 = c'GLFW_KEY_KP_3 - toC Key'Pad4 = c'GLFW_KEY_KP_4 - toC Key'Pad5 = c'GLFW_KEY_KP_5 - toC Key'Pad6 = c'GLFW_KEY_KP_6 - toC Key'Pad7 = c'GLFW_KEY_KP_7 - toC Key'Pad8 = c'GLFW_KEY_KP_8 - toC Key'Pad9 = c'GLFW_KEY_KP_9 - toC Key'PadDecimal = c'GLFW_KEY_KP_DECIMAL - toC Key'PadDivide = c'GLFW_KEY_KP_DIVIDE - toC Key'PadMultiply = c'GLFW_KEY_KP_MULTIPLY - toC Key'PadSubtract = c'GLFW_KEY_KP_SUBTRACT - toC Key'PadAdd = c'GLFW_KEY_KP_ADD - toC Key'PadEnter = c'GLFW_KEY_KP_ENTER - toC Key'PadEqual = c'GLFW_KEY_KP_EQUAL - toC Key'LeftShift = c'GLFW_KEY_LEFT_SHIFT - toC Key'LeftControl = c'GLFW_KEY_LEFT_CONTROL - toC Key'LeftAlt = c'GLFW_KEY_LEFT_ALT - toC Key'LeftSuper = c'GLFW_KEY_LEFT_SUPER - toC Key'RightShift = c'GLFW_KEY_RIGHT_SHIFT - toC Key'RightControl = c'GLFW_KEY_RIGHT_CONTROL - toC Key'RightAlt = c'GLFW_KEY_RIGHT_ALT - toC Key'RightSuper = c'GLFW_KEY_RIGHT_SUPER - toC Key'Menu = c'GLFW_KEY_MENU - -instance C CInt KeyState where - fromC v - | v == c'GLFW_PRESS = KeyState'Pressed - | v == c'GLFW_RELEASE = KeyState'Released - | v == c'GLFW_REPEAT = KeyState'Repeating - | otherwise = error $ "C CInt KeyState fromC: " ++ show v - toC KeyState'Pressed = c'GLFW_PRESS - toC KeyState'Released = c'GLFW_RELEASE - toC KeyState'Repeating = c'GLFW_REPEAT - -instance C CInt Joystick where - fromC v - | v == c'GLFW_JOYSTICK_1 = Joystick'1 - | v == c'GLFW_JOYSTICK_2 = Joystick'2 - | v == c'GLFW_JOYSTICK_3 = Joystick'3 - | v == c'GLFW_JOYSTICK_4 = Joystick'4 - | v == c'GLFW_JOYSTICK_5 = Joystick'5 - | v == c'GLFW_JOYSTICK_6 = Joystick'6 - | v == c'GLFW_JOYSTICK_7 = Joystick'7 - | v == c'GLFW_JOYSTICK_8 = Joystick'8 - | v == c'GLFW_JOYSTICK_9 = Joystick'9 - | v == c'GLFW_JOYSTICK_10 = Joystick'10 - | v == c'GLFW_JOYSTICK_11 = Joystick'11 - | v == c'GLFW_JOYSTICK_12 = Joystick'12 - | v == c'GLFW_JOYSTICK_13 = Joystick'13 - | v == c'GLFW_JOYSTICK_14 = Joystick'14 - | v == c'GLFW_JOYSTICK_15 = Joystick'15 - | v == c'GLFW_JOYSTICK_16 = Joystick'16 - | otherwise = error $ "C CInt Joystick fromC: " ++ show v - toC Joystick'1 = c'GLFW_JOYSTICK_1 - toC Joystick'2 = c'GLFW_JOYSTICK_2 - toC Joystick'3 = c'GLFW_JOYSTICK_3 - toC Joystick'4 = c'GLFW_JOYSTICK_4 - toC Joystick'5 = c'GLFW_JOYSTICK_5 - toC Joystick'6 = c'GLFW_JOYSTICK_6 - toC Joystick'7 = c'GLFW_JOYSTICK_7 - toC Joystick'8 = c'GLFW_JOYSTICK_8 - toC Joystick'9 = c'GLFW_JOYSTICK_9 - toC Joystick'10 = c'GLFW_JOYSTICK_10 - toC Joystick'11 = c'GLFW_JOYSTICK_11 - toC Joystick'12 = c'GLFW_JOYSTICK_12 - toC Joystick'13 = c'GLFW_JOYSTICK_13 - toC Joystick'14 = c'GLFW_JOYSTICK_14 - 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 - | v == c'GLFW_RELEASE = JoystickButtonState'Released - | otherwise = error $ "C CUChar JoystickButtonState fromC: " ++ show v - 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 - | v == c'GLFW_MOUSE_BUTTON_2 = MouseButton'2 - | v == c'GLFW_MOUSE_BUTTON_3 = MouseButton'3 - | v == c'GLFW_MOUSE_BUTTON_4 = MouseButton'4 - | v == c'GLFW_MOUSE_BUTTON_5 = MouseButton'5 - | v == c'GLFW_MOUSE_BUTTON_6 = MouseButton'6 - | v == c'GLFW_MOUSE_BUTTON_7 = MouseButton'7 - | v == c'GLFW_MOUSE_BUTTON_8 = MouseButton'8 - | otherwise = error $ "C CInt MouseButton fromC: " ++ show v - toC MouseButton'1 = c'GLFW_MOUSE_BUTTON_1 - toC MouseButton'2 = c'GLFW_MOUSE_BUTTON_2 - toC MouseButton'3 = c'GLFW_MOUSE_BUTTON_3 - toC MouseButton'4 = c'GLFW_MOUSE_BUTTON_4 - toC MouseButton'5 = c'GLFW_MOUSE_BUTTON_5 - toC MouseButton'6 = c'GLFW_MOUSE_BUTTON_6 - toC MouseButton'7 = c'GLFW_MOUSE_BUTTON_7 - toC MouseButton'8 = c'GLFW_MOUSE_BUTTON_8 - -instance C CInt MouseButtonState where - fromC v - | v == c'GLFW_PRESS = MouseButtonState'Pressed - | v == c'GLFW_RELEASE = MouseButtonState'Released - | otherwise = error $ "C CInt MouseButtonState fromC: " ++ show v - toC MouseButtonState'Pressed = c'GLFW_PRESS - toC MouseButtonState'Released = c'GLFW_RELEASE - -instance C CInt CursorState where - fromC v - | v == c'GLFW_TRUE = CursorState'InWindow - | v == c'GLFW_FALSE = CursorState'NotInWindow - | otherwise = error $ "C CInt CursorState fromC: " ++ show v - toC CursorState'InWindow = c'GLFW_TRUE - toC CursorState'NotInWindow = c'GLFW_FALSE - -instance C CInt CursorInputMode where - fromC v - | v == c'GLFW_CURSOR_NORMAL = CursorInputMode'Normal - | v == c'GLFW_CURSOR_HIDDEN = CursorInputMode'Hidden - | v == c'GLFW_CURSOR_DISABLED = CursorInputMode'Disabled - | otherwise = error $ "C CInt CursorInputMode fromC: " ++ show v - toC CursorInputMode'Normal = c'GLFW_CURSOR_NORMAL - toC CursorInputMode'Hidden = c'GLFW_CURSOR_HIDDEN - toC CursorInputMode'Disabled = c'GLFW_CURSOR_DISABLED - -instance C CInt StickyKeysInputMode where - fromC v - | v == c'GLFW_TRUE = StickyKeysInputMode'Enabled - | v == c'GLFW_FALSE = StickyKeysInputMode'Disabled - | otherwise = error $ "C CInt StickyKeysInputMode fromC: " ++ show v - toC StickyKeysInputMode'Enabled = c'GLFW_TRUE - toC StickyKeysInputMode'Disabled = c'GLFW_FALSE - -instance C CInt StickyMouseButtonsInputMode where - fromC v - | v == c'GLFW_TRUE = StickyMouseButtonsInputMode'Enabled - | v == c'GLFW_FALSE = StickyMouseButtonsInputMode'Disabled - | 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 - --------------------------------------------------------------------------------- - +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} + +-------------------------------------------------------------------------------- + +-- This code is generated by util/genC.hs. + +-------------------------------------------------------------------------------- + +module Graphics.UI.GLFW.C where + +-------------------------------------------------------------------------------- + +import Data.Bits ((.&.)) +import Data.Char (chr, ord) +import Foreign.C.Types (CDouble, CFloat, CInt, CUChar, CUInt, CUShort) +import Foreign.Ptr (Ptr) + +import Bindings.GLFW +import Graphics.UI.GLFW.Types + +-------------------------------------------------------------------------------- + +class C c h where + fromC :: c -> h + toC :: h -> c + +-------------------------------------------------------------------------------- + +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 + +instance C CUInt Char where + fromC = chr . fromIntegral + toC = fromIntegral . ord + +instance C CDouble Double where + fromC = realToFrac + toC = realToFrac + +instance C CInt Int where + fromC = fromIntegral + toC = fromIntegral + +instance C CUInt Int where + fromC = fromIntegral + toC = fromIntegral + +instance C CUShort Int where + fromC = fromIntegral + toC = fromIntegral + +instance C CFloat Double where + fromC = realToFrac + toC = realToFrac + +instance C (Ptr C'GLFWmonitor) Monitor where + fromC = Monitor + toC = unMonitor + +instance C (Ptr C'GLFWwindow) Window where + fromC = Window + toC = unWindow + +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 + , modifierKeysCapsLock = (v .&. c'GLFW_MOD_CAPS_LOCK) /= 0 + , modifierKeysNumLock = (v .&. c'GLFW_MOD_NUM_LOCK) /= 0 + } + toC = undefined + +instance C C'GLFWvidmode VideoMode where + fromC gvm = VideoMode + { videoModeWidth = fromIntegral $ c'GLFWvidmode'width gvm + , videoModeHeight = fromIntegral $ c'GLFWvidmode'height gvm + , videoModeRedBits = fromIntegral $ c'GLFWvidmode'redBits gvm + , videoModeGreenBits = fromIntegral $ c'GLFWvidmode'greenBits gvm + , videoModeBlueBits = fromIntegral $ c'GLFWvidmode'blueBits gvm + , videoModeRefreshRate = fromIntegral $ c'GLFWvidmode'refreshRate gvm + } + toC = undefined + +instance C CInt StandardCursorShape where + fromC v + | v == c'GLFW_ARROW_CURSOR = StandardCursorShape'Arrow + | v == c'GLFW_IBEAM_CURSOR = StandardCursorShape'IBeam + | v == c'GLFW_CROSSHAIR_CURSOR = StandardCursorShape'Crosshair + | v == c'GLFW_HAND_CURSOR = StandardCursorShape'Hand + | v == c'GLFW_HRESIZE_CURSOR = StandardCursorShape'HResize + | v == c'GLFW_VRESIZE_CURSOR = StandardCursorShape'VResize + | otherwise = error $ "C CInt StandardCursorShape fromC: " ++ show v + toC StandardCursorShape'Arrow = c'GLFW_ARROW_CURSOR + toC StandardCursorShape'IBeam = c'GLFW_IBEAM_CURSOR + toC StandardCursorShape'Crosshair = c'GLFW_CROSSHAIR_CURSOR + toC StandardCursorShape'Hand = c'GLFW_HAND_CURSOR + toC StandardCursorShape'HResize = c'GLFW_HRESIZE_CURSOR + toC StandardCursorShape'VResize = c'GLFW_VRESIZE_CURSOR + +-------------------------------------------------------------------------------- + +instance C CInt Bool where + fromC v + | v == c'GLFW_FALSE = False + | v == c'GLFW_TRUE = True + | otherwise = error $ "C CInt Bool fromC: " ++ show v + toC False = c'GLFW_FALSE + toC True = c'GLFW_TRUE + +instance C CInt Error where + fromC v + | v == c'GLFW_NOT_INITIALIZED = Error'NotInitialized + | v == c'GLFW_NO_CURRENT_CONTEXT = Error'NoCurrentContext + | v == c'GLFW_INVALID_ENUM = Error'InvalidEnum + | v == c'GLFW_INVALID_VALUE = Error'InvalidValue + | v == c'GLFW_OUT_OF_MEMORY = Error'OutOfMemory + | v == c'GLFW_API_UNAVAILABLE = Error'ApiUnavailable + | v == c'GLFW_VERSION_UNAVAILABLE = Error'VersionUnavailable + | v == c'GLFW_PLATFORM_ERROR = Error'PlatformError + | v == c'GLFW_FORMAT_UNAVAILABLE = Error'FormatUnavailable + | otherwise = error $ "C CInt Error fromC: " ++ show v + toC Error'NotInitialized = c'GLFW_NOT_INITIALIZED + toC Error'NoCurrentContext = c'GLFW_NO_CURRENT_CONTEXT + toC Error'InvalidEnum = c'GLFW_INVALID_ENUM + toC Error'InvalidValue = c'GLFW_INVALID_VALUE + toC Error'OutOfMemory = c'GLFW_OUT_OF_MEMORY + toC Error'ApiUnavailable = c'GLFW_API_UNAVAILABLE + toC Error'VersionUnavailable = c'GLFW_VERSION_UNAVAILABLE + toC Error'PlatformError = c'GLFW_PLATFORM_ERROR + toC Error'FormatUnavailable = c'GLFW_FORMAT_UNAVAILABLE + +instance C CInt InitHint where + fromC v + | 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 MonitorState where + fromC v + | 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 + | v == c'GLFW_NO_ROBUSTNESS = ContextRobustness'NoRobustness + | v == c'GLFW_NO_RESET_NOTIFICATION = ContextRobustness'NoResetNotification + | v == c'GLFW_LOSE_CONTEXT_ON_RESET = ContextRobustness'LoseContextOnReset + | otherwise = error $ "C CInt ContextRobustness fromC: " ++ show v + toC ContextRobustness'NoRobustness = c'GLFW_NO_ROBUSTNESS + 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 + | v == c'GLFW_OPENGL_COMPAT_PROFILE = OpenGLProfile'Compat + | v == c'GLFW_OPENGL_CORE_PROFILE = OpenGLProfile'Core + | otherwise = error $ "C CInt OpenGLProfile fromC: " ++ show v + toC OpenGLProfile'Any = c'GLFW_OPENGL_ANY_PROFILE + toC OpenGLProfile'Compat = c'GLFW_OPENGL_COMPAT_PROFILE + toC OpenGLProfile'Core = c'GLFW_OPENGL_CORE_PROFILE + +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 + | v == c'GLFW_KEY_SPACE = Key'Space + | v == c'GLFW_KEY_APOSTROPHE = Key'Apostrophe + | v == c'GLFW_KEY_COMMA = Key'Comma + | v == c'GLFW_KEY_MINUS = Key'Minus + | v == c'GLFW_KEY_PERIOD = Key'Period + | v == c'GLFW_KEY_SLASH = Key'Slash + | v == c'GLFW_KEY_0 = Key'0 + | v == c'GLFW_KEY_1 = Key'1 + | v == c'GLFW_KEY_2 = Key'2 + | v == c'GLFW_KEY_3 = Key'3 + | v == c'GLFW_KEY_4 = Key'4 + | v == c'GLFW_KEY_5 = Key'5 + | v == c'GLFW_KEY_6 = Key'6 + | v == c'GLFW_KEY_7 = Key'7 + | v == c'GLFW_KEY_8 = Key'8 + | v == c'GLFW_KEY_9 = Key'9 + | v == c'GLFW_KEY_SEMICOLON = Key'Semicolon + | v == c'GLFW_KEY_EQUAL = Key'Equal + | v == c'GLFW_KEY_A = Key'A + | v == c'GLFW_KEY_B = Key'B + | v == c'GLFW_KEY_C = Key'C + | v == c'GLFW_KEY_D = Key'D + | v == c'GLFW_KEY_E = Key'E + | v == c'GLFW_KEY_F = Key'F + | v == c'GLFW_KEY_G = Key'G + | v == c'GLFW_KEY_H = Key'H + | v == c'GLFW_KEY_I = Key'I + | v == c'GLFW_KEY_J = Key'J + | v == c'GLFW_KEY_K = Key'K + | v == c'GLFW_KEY_L = Key'L + | v == c'GLFW_KEY_M = Key'M + | v == c'GLFW_KEY_N = Key'N + | v == c'GLFW_KEY_O = Key'O + | v == c'GLFW_KEY_P = Key'P + | v == c'GLFW_KEY_Q = Key'Q + | v == c'GLFW_KEY_R = Key'R + | v == c'GLFW_KEY_S = Key'S + | v == c'GLFW_KEY_T = Key'T + | v == c'GLFW_KEY_U = Key'U + | v == c'GLFW_KEY_V = Key'V + | v == c'GLFW_KEY_W = Key'W + | v == c'GLFW_KEY_X = Key'X + | v == c'GLFW_KEY_Y = Key'Y + | v == c'GLFW_KEY_Z = Key'Z + | v == c'GLFW_KEY_LEFT_BRACKET = Key'LeftBracket + | v == c'GLFW_KEY_BACKSLASH = Key'Backslash + | v == c'GLFW_KEY_RIGHT_BRACKET = Key'RightBracket + | v == c'GLFW_KEY_GRAVE_ACCENT = Key'GraveAccent + | v == c'GLFW_KEY_WORLD_1 = Key'World1 + | v == c'GLFW_KEY_WORLD_2 = Key'World2 + | v == c'GLFW_KEY_ESCAPE = Key'Escape + | v == c'GLFW_KEY_ENTER = Key'Enter + | v == c'GLFW_KEY_TAB = Key'Tab + | v == c'GLFW_KEY_BACKSPACE = Key'Backspace + | v == c'GLFW_KEY_INSERT = Key'Insert + | v == c'GLFW_KEY_DELETE = Key'Delete + | v == c'GLFW_KEY_RIGHT = Key'Right + | v == c'GLFW_KEY_LEFT = Key'Left + | v == c'GLFW_KEY_DOWN = Key'Down + | v == c'GLFW_KEY_UP = Key'Up + | v == c'GLFW_KEY_PAGE_UP = Key'PageUp + | v == c'GLFW_KEY_PAGE_DOWN = Key'PageDown + | v == c'GLFW_KEY_HOME = Key'Home + | v == c'GLFW_KEY_END = Key'End + | v == c'GLFW_KEY_CAPS_LOCK = Key'CapsLock + | v == c'GLFW_KEY_SCROLL_LOCK = Key'ScrollLock + | v == c'GLFW_KEY_NUM_LOCK = Key'NumLock + | v == c'GLFW_KEY_PRINT_SCREEN = Key'PrintScreen + | v == c'GLFW_KEY_PAUSE = Key'Pause + | v == c'GLFW_KEY_F1 = Key'F1 + | v == c'GLFW_KEY_F2 = Key'F2 + | v == c'GLFW_KEY_F3 = Key'F3 + | v == c'GLFW_KEY_F4 = Key'F4 + | v == c'GLFW_KEY_F5 = Key'F5 + | v == c'GLFW_KEY_F6 = Key'F6 + | v == c'GLFW_KEY_F7 = Key'F7 + | v == c'GLFW_KEY_F8 = Key'F8 + | v == c'GLFW_KEY_F9 = Key'F9 + | v == c'GLFW_KEY_F10 = Key'F10 + | v == c'GLFW_KEY_F11 = Key'F11 + | v == c'GLFW_KEY_F12 = Key'F12 + | v == c'GLFW_KEY_F13 = Key'F13 + | v == c'GLFW_KEY_F14 = Key'F14 + | v == c'GLFW_KEY_F15 = Key'F15 + | v == c'GLFW_KEY_F16 = Key'F16 + | v == c'GLFW_KEY_F17 = Key'F17 + | v == c'GLFW_KEY_F18 = Key'F18 + | v == c'GLFW_KEY_F19 = Key'F19 + | v == c'GLFW_KEY_F20 = Key'F20 + | v == c'GLFW_KEY_F21 = Key'F21 + | v == c'GLFW_KEY_F22 = Key'F22 + | v == c'GLFW_KEY_F23 = Key'F23 + | v == c'GLFW_KEY_F24 = Key'F24 + | v == c'GLFW_KEY_F25 = Key'F25 + | v == c'GLFW_KEY_KP_0 = Key'Pad0 + | v == c'GLFW_KEY_KP_1 = Key'Pad1 + | v == c'GLFW_KEY_KP_2 = Key'Pad2 + | v == c'GLFW_KEY_KP_3 = Key'Pad3 + | v == c'GLFW_KEY_KP_4 = Key'Pad4 + | v == c'GLFW_KEY_KP_5 = Key'Pad5 + | v == c'GLFW_KEY_KP_6 = Key'Pad6 + | v == c'GLFW_KEY_KP_7 = Key'Pad7 + | v == c'GLFW_KEY_KP_8 = Key'Pad8 + | v == c'GLFW_KEY_KP_9 = Key'Pad9 + | v == c'GLFW_KEY_KP_DECIMAL = Key'PadDecimal + | v == c'GLFW_KEY_KP_DIVIDE = Key'PadDivide + | v == c'GLFW_KEY_KP_MULTIPLY = Key'PadMultiply + | v == c'GLFW_KEY_KP_SUBTRACT = Key'PadSubtract + | v == c'GLFW_KEY_KP_ADD = Key'PadAdd + | v == c'GLFW_KEY_KP_ENTER = Key'PadEnter + | v == c'GLFW_KEY_KP_EQUAL = Key'PadEqual + | v == c'GLFW_KEY_LEFT_SHIFT = Key'LeftShift + | v == c'GLFW_KEY_LEFT_CONTROL = Key'LeftControl + | v == c'GLFW_KEY_LEFT_ALT = Key'LeftAlt + | v == c'GLFW_KEY_LEFT_SUPER = Key'LeftSuper + | v == c'GLFW_KEY_RIGHT_SHIFT = Key'RightShift + | v == c'GLFW_KEY_RIGHT_CONTROL = Key'RightControl + | v == c'GLFW_KEY_RIGHT_ALT = Key'RightAlt + | v == c'GLFW_KEY_RIGHT_SUPER = Key'RightSuper + | v == c'GLFW_KEY_MENU = Key'Menu + | otherwise = error $ "C CInt Key fromC: " ++ show v + toC Key'Unknown = c'GLFW_KEY_UNKNOWN + toC Key'Space = c'GLFW_KEY_SPACE + toC Key'Apostrophe = c'GLFW_KEY_APOSTROPHE + toC Key'Comma = c'GLFW_KEY_COMMA + toC Key'Minus = c'GLFW_KEY_MINUS + toC Key'Period = c'GLFW_KEY_PERIOD + toC Key'Slash = c'GLFW_KEY_SLASH + toC Key'0 = c'GLFW_KEY_0 + toC Key'1 = c'GLFW_KEY_1 + toC Key'2 = c'GLFW_KEY_2 + toC Key'3 = c'GLFW_KEY_3 + toC Key'4 = c'GLFW_KEY_4 + toC Key'5 = c'GLFW_KEY_5 + toC Key'6 = c'GLFW_KEY_6 + toC Key'7 = c'GLFW_KEY_7 + toC Key'8 = c'GLFW_KEY_8 + toC Key'9 = c'GLFW_KEY_9 + toC Key'Semicolon = c'GLFW_KEY_SEMICOLON + toC Key'Equal = c'GLFW_KEY_EQUAL + toC Key'A = c'GLFW_KEY_A + toC Key'B = c'GLFW_KEY_B + toC Key'C = c'GLFW_KEY_C + toC Key'D = c'GLFW_KEY_D + toC Key'E = c'GLFW_KEY_E + toC Key'F = c'GLFW_KEY_F + toC Key'G = c'GLFW_KEY_G + toC Key'H = c'GLFW_KEY_H + toC Key'I = c'GLFW_KEY_I + toC Key'J = c'GLFW_KEY_J + toC Key'K = c'GLFW_KEY_K + toC Key'L = c'GLFW_KEY_L + toC Key'M = c'GLFW_KEY_M + toC Key'N = c'GLFW_KEY_N + toC Key'O = c'GLFW_KEY_O + toC Key'P = c'GLFW_KEY_P + toC Key'Q = c'GLFW_KEY_Q + toC Key'R = c'GLFW_KEY_R + toC Key'S = c'GLFW_KEY_S + toC Key'T = c'GLFW_KEY_T + toC Key'U = c'GLFW_KEY_U + toC Key'V = c'GLFW_KEY_V + toC Key'W = c'GLFW_KEY_W + toC Key'X = c'GLFW_KEY_X + toC Key'Y = c'GLFW_KEY_Y + toC Key'Z = c'GLFW_KEY_Z + toC Key'LeftBracket = c'GLFW_KEY_LEFT_BRACKET + toC Key'Backslash = c'GLFW_KEY_BACKSLASH + toC Key'RightBracket = c'GLFW_KEY_RIGHT_BRACKET + toC Key'GraveAccent = c'GLFW_KEY_GRAVE_ACCENT + toC Key'World1 = c'GLFW_KEY_WORLD_1 + toC Key'World2 = c'GLFW_KEY_WORLD_2 + toC Key'Escape = c'GLFW_KEY_ESCAPE + toC Key'Enter = c'GLFW_KEY_ENTER + toC Key'Tab = c'GLFW_KEY_TAB + toC Key'Backspace = c'GLFW_KEY_BACKSPACE + toC Key'Insert = c'GLFW_KEY_INSERT + toC Key'Delete = c'GLFW_KEY_DELETE + toC Key'Right = c'GLFW_KEY_RIGHT + toC Key'Left = c'GLFW_KEY_LEFT + toC Key'Down = c'GLFW_KEY_DOWN + toC Key'Up = c'GLFW_KEY_UP + toC Key'PageUp = c'GLFW_KEY_PAGE_UP + toC Key'PageDown = c'GLFW_KEY_PAGE_DOWN + toC Key'Home = c'GLFW_KEY_HOME + toC Key'End = c'GLFW_KEY_END + toC Key'CapsLock = c'GLFW_KEY_CAPS_LOCK + toC Key'ScrollLock = c'GLFW_KEY_SCROLL_LOCK + toC Key'NumLock = c'GLFW_KEY_NUM_LOCK + toC Key'PrintScreen = c'GLFW_KEY_PRINT_SCREEN + toC Key'Pause = c'GLFW_KEY_PAUSE + toC Key'F1 = c'GLFW_KEY_F1 + toC Key'F2 = c'GLFW_KEY_F2 + toC Key'F3 = c'GLFW_KEY_F3 + toC Key'F4 = c'GLFW_KEY_F4 + toC Key'F5 = c'GLFW_KEY_F5 + toC Key'F6 = c'GLFW_KEY_F6 + toC Key'F7 = c'GLFW_KEY_F7 + toC Key'F8 = c'GLFW_KEY_F8 + toC Key'F9 = c'GLFW_KEY_F9 + toC Key'F10 = c'GLFW_KEY_F10 + toC Key'F11 = c'GLFW_KEY_F11 + toC Key'F12 = c'GLFW_KEY_F12 + toC Key'F13 = c'GLFW_KEY_F13 + toC Key'F14 = c'GLFW_KEY_F14 + toC Key'F15 = c'GLFW_KEY_F15 + toC Key'F16 = c'GLFW_KEY_F16 + toC Key'F17 = c'GLFW_KEY_F17 + toC Key'F18 = c'GLFW_KEY_F18 + toC Key'F19 = c'GLFW_KEY_F19 + toC Key'F20 = c'GLFW_KEY_F20 + toC Key'F21 = c'GLFW_KEY_F21 + toC Key'F22 = c'GLFW_KEY_F22 + toC Key'F23 = c'GLFW_KEY_F23 + toC Key'F24 = c'GLFW_KEY_F24 + toC Key'F25 = c'GLFW_KEY_F25 + toC Key'Pad0 = c'GLFW_KEY_KP_0 + toC Key'Pad1 = c'GLFW_KEY_KP_1 + toC Key'Pad2 = c'GLFW_KEY_KP_2 + toC Key'Pad3 = c'GLFW_KEY_KP_3 + toC Key'Pad4 = c'GLFW_KEY_KP_4 + toC Key'Pad5 = c'GLFW_KEY_KP_5 + toC Key'Pad6 = c'GLFW_KEY_KP_6 + toC Key'Pad7 = c'GLFW_KEY_KP_7 + toC Key'Pad8 = c'GLFW_KEY_KP_8 + toC Key'Pad9 = c'GLFW_KEY_KP_9 + toC Key'PadDecimal = c'GLFW_KEY_KP_DECIMAL + toC Key'PadDivide = c'GLFW_KEY_KP_DIVIDE + toC Key'PadMultiply = c'GLFW_KEY_KP_MULTIPLY + toC Key'PadSubtract = c'GLFW_KEY_KP_SUBTRACT + toC Key'PadAdd = c'GLFW_KEY_KP_ADD + toC Key'PadEnter = c'GLFW_KEY_KP_ENTER + toC Key'PadEqual = c'GLFW_KEY_KP_EQUAL + toC Key'LeftShift = c'GLFW_KEY_LEFT_SHIFT + toC Key'LeftControl = c'GLFW_KEY_LEFT_CONTROL + toC Key'LeftAlt = c'GLFW_KEY_LEFT_ALT + toC Key'LeftSuper = c'GLFW_KEY_LEFT_SUPER + toC Key'RightShift = c'GLFW_KEY_RIGHT_SHIFT + toC Key'RightControl = c'GLFW_KEY_RIGHT_CONTROL + toC Key'RightAlt = c'GLFW_KEY_RIGHT_ALT + toC Key'RightSuper = c'GLFW_KEY_RIGHT_SUPER + toC Key'Menu = c'GLFW_KEY_MENU + +instance C CInt KeyState where + fromC v + | v == c'GLFW_PRESS = KeyState'Pressed + | v == c'GLFW_RELEASE = KeyState'Released + | v == c'GLFW_REPEAT = KeyState'Repeating + | otherwise = error $ "C CInt KeyState fromC: " ++ show v + toC KeyState'Pressed = c'GLFW_PRESS + toC KeyState'Released = c'GLFW_RELEASE + toC KeyState'Repeating = c'GLFW_REPEAT + +instance C CInt Joystick where + fromC v + | v == c'GLFW_JOYSTICK_1 = Joystick'1 + | v == c'GLFW_JOYSTICK_2 = Joystick'2 + | v == c'GLFW_JOYSTICK_3 = Joystick'3 + | v == c'GLFW_JOYSTICK_4 = Joystick'4 + | v == c'GLFW_JOYSTICK_5 = Joystick'5 + | v == c'GLFW_JOYSTICK_6 = Joystick'6 + | v == c'GLFW_JOYSTICK_7 = Joystick'7 + | v == c'GLFW_JOYSTICK_8 = Joystick'8 + | v == c'GLFW_JOYSTICK_9 = Joystick'9 + | v == c'GLFW_JOYSTICK_10 = Joystick'10 + | v == c'GLFW_JOYSTICK_11 = Joystick'11 + | v == c'GLFW_JOYSTICK_12 = Joystick'12 + | v == c'GLFW_JOYSTICK_13 = Joystick'13 + | v == c'GLFW_JOYSTICK_14 = Joystick'14 + | v == c'GLFW_JOYSTICK_15 = Joystick'15 + | v == c'GLFW_JOYSTICK_16 = Joystick'16 + | otherwise = error $ "C CInt Joystick fromC: " ++ show v + toC Joystick'1 = c'GLFW_JOYSTICK_1 + toC Joystick'2 = c'GLFW_JOYSTICK_2 + toC Joystick'3 = c'GLFW_JOYSTICK_3 + toC Joystick'4 = c'GLFW_JOYSTICK_4 + toC Joystick'5 = c'GLFW_JOYSTICK_5 + toC Joystick'6 = c'GLFW_JOYSTICK_6 + toC Joystick'7 = c'GLFW_JOYSTICK_7 + toC Joystick'8 = c'GLFW_JOYSTICK_8 + toC Joystick'9 = c'GLFW_JOYSTICK_9 + toC Joystick'10 = c'GLFW_JOYSTICK_10 + toC Joystick'11 = c'GLFW_JOYSTICK_11 + toC Joystick'12 = c'GLFW_JOYSTICK_12 + toC Joystick'13 = c'GLFW_JOYSTICK_13 + toC Joystick'14 = c'GLFW_JOYSTICK_14 + 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 + | v == c'GLFW_RELEASE = JoystickButtonState'Released + | otherwise = error $ "C CUChar JoystickButtonState fromC: " ++ show v + 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 + | v == c'GLFW_MOUSE_BUTTON_2 = MouseButton'2 + | v == c'GLFW_MOUSE_BUTTON_3 = MouseButton'3 + | v == c'GLFW_MOUSE_BUTTON_4 = MouseButton'4 + | v == c'GLFW_MOUSE_BUTTON_5 = MouseButton'5 + | v == c'GLFW_MOUSE_BUTTON_6 = MouseButton'6 + | v == c'GLFW_MOUSE_BUTTON_7 = MouseButton'7 + | v == c'GLFW_MOUSE_BUTTON_8 = MouseButton'8 + | otherwise = error $ "C CInt MouseButton fromC: " ++ show v + toC MouseButton'1 = c'GLFW_MOUSE_BUTTON_1 + toC MouseButton'2 = c'GLFW_MOUSE_BUTTON_2 + toC MouseButton'3 = c'GLFW_MOUSE_BUTTON_3 + toC MouseButton'4 = c'GLFW_MOUSE_BUTTON_4 + toC MouseButton'5 = c'GLFW_MOUSE_BUTTON_5 + toC MouseButton'6 = c'GLFW_MOUSE_BUTTON_6 + toC MouseButton'7 = c'GLFW_MOUSE_BUTTON_7 + toC MouseButton'8 = c'GLFW_MOUSE_BUTTON_8 + +instance C CInt MouseButtonState where + fromC v + | v == c'GLFW_PRESS = MouseButtonState'Pressed + | v == c'GLFW_RELEASE = MouseButtonState'Released + | otherwise = error $ "C CInt MouseButtonState fromC: " ++ show v + toC MouseButtonState'Pressed = c'GLFW_PRESS + toC MouseButtonState'Released = c'GLFW_RELEASE + +instance C CInt CursorState where + fromC v + | v == c'GLFW_TRUE = CursorState'InWindow + | v == c'GLFW_FALSE = CursorState'NotInWindow + | otherwise = error $ "C CInt CursorState fromC: " ++ show v + toC CursorState'InWindow = c'GLFW_TRUE + toC CursorState'NotInWindow = c'GLFW_FALSE + +instance C CInt CursorInputMode where + fromC v + | v == c'GLFW_CURSOR_NORMAL = CursorInputMode'Normal + | v == c'GLFW_CURSOR_HIDDEN = CursorInputMode'Hidden + | v == c'GLFW_CURSOR_DISABLED = CursorInputMode'Disabled + | otherwise = error $ "C CInt CursorInputMode fromC: " ++ show v + toC CursorInputMode'Normal = c'GLFW_CURSOR_NORMAL + toC CursorInputMode'Hidden = c'GLFW_CURSOR_HIDDEN + toC CursorInputMode'Disabled = c'GLFW_CURSOR_DISABLED + +instance C CInt StickyKeysInputMode where + fromC v + | v == c'GLFW_TRUE = StickyKeysInputMode'Enabled + | v == c'GLFW_FALSE = StickyKeysInputMode'Disabled + | otherwise = error $ "C CInt StickyKeysInputMode fromC: " ++ show v + toC StickyKeysInputMode'Enabled = c'GLFW_TRUE + toC StickyKeysInputMode'Disabled = c'GLFW_FALSE + +instance C CInt StickyMouseButtonsInputMode where + fromC v + | v == c'GLFW_TRUE = StickyMouseButtonsInputMode'Enabled + | v == c'GLFW_FALSE = StickyMouseButtonsInputMode'Disabled + | 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 + +-------------------------------------------------------------------------------- + {-# ANN module "HLint: ignore Use camelCase" #-} 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 @@ -1,647 +1,647 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | The types of the package. This module is considered "internal", and the --- types are re-exported from Graphics.UI.GLFW as necessary. -module Graphics.UI.GLFW.Types where - --------------------------------------------------------------------------------- - -import Control.DeepSeq (NFData) -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 - -import Bindings.GLFW - --------------------------------------------------------------------------------- --- Error handling - --- | 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 -- ^ - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData Error - --------------------------------------------------------------------------------- --- 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 -data Version = Version - { versionMajor :: {-# UNPACK #-} !Int - , versionMinor :: {-# UNPACK #-} !Int - , versionRevision :: {-# UNPACK #-} !Int - } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData Version - --------------------------------------------------------------------------------- --- Monitor handling - --- | Represents a physical monitor that's currently connected. --- See the -newtype Monitor = Monitor - { unMonitor :: Ptr C'GLFWmonitor - } deriving (Data, Eq, Ord, Show, Typeable, Generic) - --- | Part of the t'Graphics.UI.GLFW.MonitorCallback', for when a monitor gets --- connected or disconnected. -data MonitorState = - MonitorState'Connected - | MonitorState'Disconnected - deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData MonitorState - --- | See -data VideoMode = VideoMode - { 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 . -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. - { gammaRampRed :: [Int] - , gammaRampGreen :: [Int] - , gammaRampBlue :: [Int] - } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData GammaRamp - --- | Smart constructor for a 'GammaRamp'. -makeGammaRamp :: [Int] -> [Int] -> [Int] -> Maybe GammaRamp -makeGammaRamp rs gs bs - | lengthsEqual = Just $ GammaRamp rs gs bs - | otherwise = Nothing - where - lengthsEqual = - let rsl = length rs - gsl = length gs - bsl = length bs - in rsl == gsl && gsl == bsl - --------------------------------------------------------------------------------- --- Window handling - --- | Collects all the callbacks that can be associated with a Window into a single place. -data WindowCallbacks = WindowCallbacks - { 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 -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 . -data WindowHint = - 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 - --- | 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 WindowAttrib - --- | The OpenGL robustness strategy. -data ContextRobustness = - ContextRobustness'NoRobustness - | ContextRobustness'NoResetNotification - | ContextRobustness'LoseContextOnReset - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData ContextRobustness - --- | The OpenGL profile. -data OpenGLProfile = - OpenGLProfile'Any - | OpenGLProfile'Compat - | OpenGLProfile'Core - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData OpenGLProfile - --- | The type of OpenGL to create a context for. -data ClientAPI = - 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. -data Key = - Key'Unknown - | Key'Space - | Key'Apostrophe - | Key'Comma - | Key'Minus - | Key'Period - | Key'Slash - | Key'0 - | Key'1 - | Key'2 - | Key'3 - | Key'4 - | Key'5 - | Key'6 - | Key'7 - | Key'8 - | Key'9 - | Key'Semicolon - | Key'Equal - | Key'A - | Key'B - | Key'C - | Key'D - | Key'E - | Key'F - | Key'G - | Key'H - | Key'I - | Key'J - | Key'K - | Key'L - | Key'M - | Key'N - | Key'O - | Key'P - | Key'Q - | Key'R - | Key'S - | Key'T - | Key'U - | Key'V - | Key'W - | Key'X - | Key'Y - | Key'Z - | Key'LeftBracket - | Key'Backslash - | Key'RightBracket - | Key'GraveAccent - | Key'World1 - | Key'World2 - | Key'Escape - | Key'Enter - | Key'Tab - | Key'Backspace - | Key'Insert - | Key'Delete - | Key'Right - | Key'Left - | Key'Down - | Key'Up - | Key'PageUp - | Key'PageDown - | Key'Home - | Key'End - | Key'CapsLock - | Key'ScrollLock - | Key'NumLock - | Key'PrintScreen - | Key'Pause - | Key'F1 - | Key'F2 - | Key'F3 - | Key'F4 - | Key'F5 - | Key'F6 - | Key'F7 - | Key'F8 - | Key'F9 - | Key'F10 - | Key'F11 - | Key'F12 - | Key'F13 - | Key'F14 - | Key'F15 - | Key'F16 - | Key'F17 - | Key'F18 - | Key'F19 - | Key'F20 - | Key'F21 - | Key'F22 - | Key'F23 - | Key'F24 - | Key'F25 - | Key'Pad0 - | Key'Pad1 - | Key'Pad2 - | Key'Pad3 - | Key'Pad4 - | Key'Pad5 - | Key'Pad6 - | Key'Pad7 - | Key'Pad8 - | Key'Pad9 - | Key'PadDecimal - | Key'PadDivide - | Key'PadMultiply - | Key'PadSubtract - | Key'PadAdd - | Key'PadEnter - | Key'PadEqual - | Key'LeftShift - | Key'LeftControl - | Key'LeftAlt - | Key'LeftSuper - | Key'RightShift - | Key'RightControl - | Key'RightAlt - | Key'RightSuper - | Key'Menu - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData Key - --- | The state of an individual key when 'Graphics.UI.GLFW.getKey' is called. -data KeyState = - KeyState'Pressed - | KeyState'Released - | KeyState'Repeating - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData KeyState - --- | For use with the system. -data Joystick = - Joystick'1 - | Joystick'2 - | Joystick'3 - | Joystick'4 - | Joystick'5 - | Joystick'6 - | Joystick'7 - | Joystick'8 - | Joystick'9 - | Joystick'10 - | Joystick'11 - | Joystick'12 - | Joystick'13 - | Joystick'14 - | Joystick'15 - | Joystick'16 - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData Joystick - --- | If a given joystick button is pressed or not when --- 'Graphics.UI.GLFW.getJoystickButtons' is called. -data JoystickButtonState = - JoystickButtonState'Pressed - | JoystickButtonState'Released - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData JoystickButtonState - --- | 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 - | MouseButton'3 - | MouseButton'4 - | MouseButton'5 - | MouseButton'6 - | MouseButton'7 - | MouseButton'8 - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData MouseButton - --- | If the mouse button is pressed or not when 'Graphics.UI.GLFW.getMouseButton' is --- called. -data MouseButtonState = - MouseButtonState'Pressed - | MouseButtonState'Released - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData MouseButtonState - --- | If the mouse's cursor is in the window or not. -data CursorState = - CursorState'InWindow - | CursorState'NotInWindow - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData CursorState - --- | Allows for special forms of mouse input. --- See -data CursorInputMode = - CursorInputMode'Normal - | CursorInputMode'Hidden - | CursorInputMode'Disabled - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -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 '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 - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData StickyKeysInputMode - --- | This is the mouse version of "StickyKeysInputMode". -data StickyMouseButtonsInputMode = - StickyMouseButtonsInputMode'Enabled - | StickyMouseButtonsInputMode'Disabled - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData StickyMouseButtonsInputMode - --- | Modifier keys that were pressed as part of another keypress event. -data ModifierKeys = ModifierKeys - { modifierKeysShift :: !Bool - , modifierKeysControl :: !Bool - , modifierKeysAlt :: !Bool - , modifierKeysSuper :: !Bool - , modifierKeysCapsLock :: !Bool - , modifierKeysNumLock :: !Bool - } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData ModifierKeys - --- | 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 :: {-# 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. -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 . -data StandardCursorShape = - StandardCursorShape'Arrow - | StandardCursorShape'IBeam - | StandardCursorShape'Crosshair - | StandardCursorShape'Hand - | StandardCursorShape'HResize - | StandardCursorShape'VResize - deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) - -instance NFData StandardCursorShape - --------------------------------------------------------------------------------- - -{-# ANN module "HLint: ignore Use camelCase" #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | The types of the package. This module is considered "internal", and the +-- types are re-exported from Graphics.UI.GLFW as necessary. +module Graphics.UI.GLFW.Types where + +-------------------------------------------------------------------------------- + +import Control.DeepSeq (NFData) +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 + +import Bindings.GLFW + +-------------------------------------------------------------------------------- +-- Error handling + +-- | 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 -- ^ + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData Error + +-------------------------------------------------------------------------------- +-- 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 +data Version = Version + { versionMajor :: {-# UNPACK #-} !Int + , versionMinor :: {-# UNPACK #-} !Int + , versionRevision :: {-# UNPACK #-} !Int + } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData Version + +-------------------------------------------------------------------------------- +-- Monitor handling + +-- | Represents a physical monitor that's currently connected. +-- See the +newtype Monitor = Monitor + { unMonitor :: Ptr C'GLFWmonitor + } deriving (Data, Eq, Ord, Show, Typeable, Generic) + +-- | Part of the t'Graphics.UI.GLFW.MonitorCallback', for when a monitor gets +-- connected or disconnected. +data MonitorState = + MonitorState'Connected + | MonitorState'Disconnected + deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData MonitorState + +-- | See +data VideoMode = VideoMode + { 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 . +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. + { gammaRampRed :: [Int] + , gammaRampGreen :: [Int] + , gammaRampBlue :: [Int] + } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData GammaRamp + +-- | Smart constructor for a 'GammaRamp'. +makeGammaRamp :: [Int] -> [Int] -> [Int] -> Maybe GammaRamp +makeGammaRamp rs gs bs + | lengthsEqual = Just $ GammaRamp rs gs bs + | otherwise = Nothing + where + lengthsEqual = + let rsl = length rs + gsl = length gs + bsl = length bs + in rsl == gsl && gsl == bsl + +-------------------------------------------------------------------------------- +-- Window handling + +-- | Collects all the callbacks that can be associated with a Window into a single place. +data WindowCallbacks = WindowCallbacks + { 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) + } + +-- | 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 . +data WindowHint = + 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 + +-- | 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 WindowAttrib + +-- | The OpenGL robustness strategy. +data ContextRobustness = + ContextRobustness'NoRobustness + | ContextRobustness'NoResetNotification + | ContextRobustness'LoseContextOnReset + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData ContextRobustness + +-- | The OpenGL profile. +data OpenGLProfile = + OpenGLProfile'Any + | OpenGLProfile'Compat + | OpenGLProfile'Core + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData OpenGLProfile + +-- | The type of OpenGL to create a context for. +data ClientAPI = + 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. +data Key = + Key'Unknown + | Key'Space + | Key'Apostrophe + | Key'Comma + | Key'Minus + | Key'Period + | Key'Slash + | Key'0 + | Key'1 + | Key'2 + | Key'3 + | Key'4 + | Key'5 + | Key'6 + | Key'7 + | Key'8 + | Key'9 + | Key'Semicolon + | Key'Equal + | Key'A + | Key'B + | Key'C + | Key'D + | Key'E + | Key'F + | Key'G + | Key'H + | Key'I + | Key'J + | Key'K + | Key'L + | Key'M + | Key'N + | Key'O + | Key'P + | Key'Q + | Key'R + | Key'S + | Key'T + | Key'U + | Key'V + | Key'W + | Key'X + | Key'Y + | Key'Z + | Key'LeftBracket + | Key'Backslash + | Key'RightBracket + | Key'GraveAccent + | Key'World1 + | Key'World2 + | Key'Escape + | Key'Enter + | Key'Tab + | Key'Backspace + | Key'Insert + | Key'Delete + | Key'Right + | Key'Left + | Key'Down + | Key'Up + | Key'PageUp + | Key'PageDown + | Key'Home + | Key'End + | Key'CapsLock + | Key'ScrollLock + | Key'NumLock + | Key'PrintScreen + | Key'Pause + | Key'F1 + | Key'F2 + | Key'F3 + | Key'F4 + | Key'F5 + | Key'F6 + | Key'F7 + | Key'F8 + | Key'F9 + | Key'F10 + | Key'F11 + | Key'F12 + | Key'F13 + | Key'F14 + | Key'F15 + | Key'F16 + | Key'F17 + | Key'F18 + | Key'F19 + | Key'F20 + | Key'F21 + | Key'F22 + | Key'F23 + | Key'F24 + | Key'F25 + | Key'Pad0 + | Key'Pad1 + | Key'Pad2 + | Key'Pad3 + | Key'Pad4 + | Key'Pad5 + | Key'Pad6 + | Key'Pad7 + | Key'Pad8 + | Key'Pad9 + | Key'PadDecimal + | Key'PadDivide + | Key'PadMultiply + | Key'PadSubtract + | Key'PadAdd + | Key'PadEnter + | Key'PadEqual + | Key'LeftShift + | Key'LeftControl + | Key'LeftAlt + | Key'LeftSuper + | Key'RightShift + | Key'RightControl + | Key'RightAlt + | Key'RightSuper + | Key'Menu + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData Key + +-- | The state of an individual key when 'Graphics.UI.GLFW.getKey' is called. +data KeyState = + KeyState'Pressed + | KeyState'Released + | KeyState'Repeating + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData KeyState + +-- | For use with the system. +data Joystick = + Joystick'1 + | Joystick'2 + | Joystick'3 + | Joystick'4 + | Joystick'5 + | Joystick'6 + | Joystick'7 + | Joystick'8 + | Joystick'9 + | Joystick'10 + | Joystick'11 + | Joystick'12 + | Joystick'13 + | Joystick'14 + | Joystick'15 + | Joystick'16 + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData Joystick + +-- | If a given joystick button is pressed or not when +-- 'Graphics.UI.GLFW.getJoystickButtons' is called. +data JoystickButtonState = + JoystickButtonState'Pressed + | JoystickButtonState'Released + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData JoystickButtonState + +-- | 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 + | MouseButton'3 + | MouseButton'4 + | MouseButton'5 + | MouseButton'6 + | MouseButton'7 + | MouseButton'8 + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData MouseButton + +-- | If the mouse button is pressed or not when 'Graphics.UI.GLFW.getMouseButton' is +-- called. +data MouseButtonState = + MouseButtonState'Pressed + | MouseButtonState'Released + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData MouseButtonState + +-- | If the mouse's cursor is in the window or not. +data CursorState = + CursorState'InWindow + | CursorState'NotInWindow + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData CursorState + +-- | Allows for special forms of mouse input. +-- See +data CursorInputMode = + CursorInputMode'Normal + | CursorInputMode'Hidden + | CursorInputMode'Disabled + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +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 '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 + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData StickyKeysInputMode + +-- | This is the mouse version of "StickyKeysInputMode". +data StickyMouseButtonsInputMode = + StickyMouseButtonsInputMode'Enabled + | StickyMouseButtonsInputMode'Disabled + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData StickyMouseButtonsInputMode + +-- | Modifier keys that were pressed as part of another keypress event. +data ModifierKeys = ModifierKeys + { modifierKeysShift :: !Bool + , modifierKeysControl :: !Bool + , modifierKeysAlt :: !Bool + , modifierKeysSuper :: !Bool + , modifierKeysCapsLock :: !Bool + , modifierKeysNumLock :: !Bool + } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData ModifierKeys + +-- | 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 :: {-# 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 + +-- | 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 . +data StandardCursorShape = + StandardCursorShape'Arrow + | StandardCursorShape'IBeam + | StandardCursorShape'Crosshair + | StandardCursorShape'Hand + | StandardCursorShape'HResize + | StandardCursorShape'VResize + deriving (Bounded, Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) + +instance NFData StandardCursorShape + +-------------------------------------------------------------------------------- + +{-# ANN module "HLint: ignore Use camelCase" #-} diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,44 +1,44 @@ -GLFW-b -====== -[![Hackage](https://img.shields.io/hackage/v/GLFW-b.svg)](http://hackage.haskell.org/package/GLFW-b) - -## Description - -[Haskell][1] bindings to [GLFW][2], an Open Source, multi-platform library for -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]. - -For a demonstration of GLFW-b, see [GLFW-b-demo][5]. - -When running GLFW-b in GHCI, don't forget to - - :set -fno-ghci-sandbox - -since GHCI can (and might) run each line of your code in a fresh unbounded -thread. - -## Contributing - -This package uses git-flow as development model, in short that means that: - -1. New features should be added to "develop" branch. -2. "master" branch is reserved for stable releases. -3. Patches for bugs related with previous releases should always be done in - "hotfixes" branch. -4. All merge commits to master from "hotfixes" should be done - using the "--no-ff" flag and from "develop" should avoid merging commits. - -Until we have a defined road-map we are going to leave out "release -"branches" and "feature branches". For more information about this development -model please refer to [this site.][6] - -Thanks you, and happy coding. - -[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 -[5]: https://github.com/bsl/GLFW-b-demo -[6]: http://nvie.com/posts/a-successful-git-branching-model/ +GLFW-b +====== +[![Hackage](https://img.shields.io/hackage/v/GLFW-b.svg)](http://hackage.haskell.org/package/GLFW-b) + +## Description + +[Haskell][1] bindings to [GLFW][2], an Open Source, multi-platform library for +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.3, [released 2019-04-15][4]. + +For a demonstration of GLFW-b, see [GLFW-b-demo][5]. + +When running GLFW-b in GHCI, don't forget to + + :set -fno-ghci-sandbox + +since GHCI can (and might) run each line of your code in a fresh unbounded +thread. + +## Contributing + +This package uses git-flow as development model, in short that means that: + +1. New features should be added to "develop" branch. +2. "master" branch is reserved for stable releases. +3. Patches for bugs related with previous releases should always be done in + "hotfixes" branch. +4. All merge commits to master from "hotfixes" should be done + using the "--no-ff" flag and from "develop" should avoid merging commits. + +Until we have a defined road-map we are going to leave out "release +"branches" and "feature branches". For more information about this development +model please refer to [this site.][6] + +Thanks you, and happy coding. + +[1]: http://www.haskell.org/ +[2]: http://www.glfw.org/ +[3]: https://github.com/bsl/bindings-GLFW +[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/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,685 +1,683 @@ --- 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) - --- test-framework -import Test.Framework (Test, defaultMain, testGroup) - --- test-framework-hunit -import Test.Framework.Providers.HUnit (testCase) - --- GLFW-b -import qualified Graphics.UI.GLFW as GLFW - --------------------------------------------------------------------------------- - -main :: IO () -main = do - 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 - GLFW.destroyWindow win - GLFW.terminate - --------------------------------------------------------------------------------- - -versionMajor, versionMinor, versionRevision :: Int -versionMajor = 3 -versionMinor = 3 -versionRevision = 0 - -giveItTime :: IO () -giveItTime = threadDelay 500000 - -joysticks :: [GLFW.Joystick] -joysticks = - [ GLFW.Joystick'1 - , GLFW.Joystick'2 - , GLFW.Joystick'3 - , GLFW.Joystick'4 - , GLFW.Joystick'5 - , GLFW.Joystick'6 - , GLFW.Joystick'7 - , GLFW.Joystick'8 - , GLFW.Joystick'9 - , GLFW.Joystick'10 - , GLFW.Joystick'11 - , GLFW.Joystick'12 - , GLFW.Joystick'13 - , GLFW.Joystick'14 - , GLFW.Joystick'15 - , GLFW.Joystick'16 - ] - -between :: Ord a => a -> (a,a) -> Bool -between n (l,h) = n >= l && n <= h - -videoModeLooksValid :: GLFW.VideoMode -> Bool -videoModeLooksValid vm = and - [ GLFW.videoModeWidth vm `between` (0,4000) - , GLFW.videoModeHeight vm `between` (0,3000) - , GLFW.videoModeRedBits vm `between` (0, 32) - , GLFW.videoModeGreenBits vm `between` (0, 32) - , GLFW.videoModeBlueBits vm `between` (0, 32) - , GLFW.videoModeRefreshRate vm `between` (0, 120) - ] - --------------------------------------------------------------------------------- - -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" - [ 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" - [ 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" - [ 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" - [ glfwTest "getTime" test_getTime - , glfwTest "setTime" test_setTime - , glfwTest "getTimerValue" test_getTimerValue - , glfwTest "getTimerFrequency" test_getTimerFrequency - ] - , testGroup "Context" - [ glfwTest "getCurrentContext" $ test_getCurrentContext win - , glfwTest "swapBuffers" $ test_swapBuffers win - , glfwTest "swapInterval" test_swapInterval - , glfwTest "extensionSupported" test_extensionSupported - ] - , testGroup "Clipboard" - [ glfwTest "clipboard" $ test_clipboard win - ] - ] - --------------------------------------------------------------------------------- - -test_getVersion :: IO () -test_getVersion = do - v <- GLFW.getVersion - GLFW.versionMajor v @?= versionMajor - GLFW.versionMinor v @?= versionMinor - GLFW.versionRevision v @?= versionRevision - -test_getVersionString :: IO () -test_getVersionString = do - mvs <- GLFW.getVersionString - case mvs of - Just vs -> assertBool "" $ v `isPrefixOf` vs - Nothing -> assertFailure "" - 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 - case r of - Just ms -> assertBool "" $ (not . null) ms - Nothing -> assertFailure "" - -test_getPrimaryMonitor :: IO () -test_getPrimaryMonitor = do - r <- GLFW.getPrimaryMonitor - case r of - Just _ -> return () - Nothing -> assertFailure "" - -test_getMonitorPos :: GLFW.Monitor -> IO () -test_getMonitorPos mon = do - (x, y) <- GLFW.getMonitorPos mon - assertBool "" $ x >= 0 - assertBool "" $ y >= 0 - -test_getMonitorPhysicalSize :: GLFW.Monitor -> IO () -test_getMonitorPhysicalSize mon = do - (w, h) <- GLFW.getMonitorPhysicalSize mon - 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 - -test_getVideoModes :: GLFW.Monitor -> IO () -test_getVideoModes mon = do - mvms <- GLFW.getVideoModes mon - case mvms of - Nothing -> assertFailure "" - Just vms -> assertBool "" $ all videoModeLooksValid vms - -test_getVideoMode :: GLFW.Monitor -> IO () -test_getVideoMode mon = do - mvm <- GLFW.getVideoMode mon - case mvm of - Just vm -> assertBool "" $ videoModeLooksValid vm - Nothing -> assertFailure "" - -test_getGammaRamp :: GLFW.Monitor -> IO () -test_getGammaRamp mon = do - mgr <- GLFW.getGammaRamp mon - case mgr of - Nothing -> assertFailure "" - Just gr -> assertBool "" $ - let rsl = length $ GLFW.gammaRampRed gr - gsl = length $ GLFW.gammaRampGreen gr - bsl = length $ GLFW.gammaRampBlue gr - in rsl > 0 && rsl == gsl && gsl == bsl - --------------------------------------------------------------------------------- - -test_defaultWindowHints :: IO () -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 - r0 @?= False - - GLFW.setWindowShouldClose win True - r1 <- GLFW.windowShouldClose win - r1 @?= True - - GLFW.setWindowShouldClose win False - 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" - --- This is a little strange. Depending on your window manager, etc, after --- setting the window position to (x,y), the actual new window position might --- be (x+5,y+5) due to borders. So we just check for consistency. -test_window_pos :: GLFW.Window -> IO () -test_window_pos win = do - let x = 17 - y = 37 - xoff = 53 - yoff = 149 - (x0, y0, dx0, dy0) <- setGet x y - (x1, y1, dx1, dy1) <- setGet (x+xoff) (y+yoff) - dx0 @?= dx1 - dy0 @?= dy1 - x1 - x0 @?= xoff - y1 - y0 @?= yoff - where - setGet x0 y0 = do - GLFW.setWindowPos win x0 y0 - giveItTime - (x1, y1) <- GLFW.getWindowPos win - let (dx, dy) = (x0-x1, y0-y1) - return (x1, y1, dx, dy) - -test_window_size :: GLFW.Window -> IO () -test_window_size win = do - 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 - (fw, fh) <- GLFW.getFramebufferSize win - -- Window size and framebuffer size are not always equal, an example are - -- retina screens. But maybe it's safe to assume they'll always be scaled - -- equally in both dimensions? - let ww = ( fromIntegral fw / fromIntegral w ) :: Double - hh = ( fromIntegral fh / fromIntegral h ) :: Double - ww @?= hh - assertBool "" $ fw /= 0 - assertBool "" $ fh /= 0 - -test_iconification :: GLFW.Window -> IO () -test_iconification win = do - GLFW.showWindow win - is0 <- GLFW.getWindowIconified win - is0 @?= False - - GLFW.iconifyWindow win - giveItTime - is1 <- GLFW.getWindowIconified win - is1 @?= True - - GLFW.restoreWindow win - GLFW.hideWindow win - --- test_show_hide :: GLFW.Window -> IO () --- test_show_hide win = do --- v0 <- GLFW.getWindowVisible win --- v0 @?= True - --- GLFW.hideWindow win --- giveItTime --- v1 <- GLFW.getWindowVisible win --- v1 @?= False - --- GLFW.showWindow win --- giveItTime --- v2 <- GLFW.getWindowVisible win --- v2 @?= True - -test_getWindowMonitor :: GLFW.Window -> GLFW.Monitor -> IO () -test_getWindowMonitor win _ = do - 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 - 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 @?= False - -test_getWindowResizable :: GLFW.Window -> IO () -test_getWindowResizable win = do - b <- GLFW.getWindowResizable win - b @?= True - -test_getWindowDecorated :: GLFW.Window -> IO () -test_getWindowDecorated win = do - b <- GLFW.getWindowDecorated win - b @?= True - -test_getWindowClientAPI :: GLFW.Window -> IO () -test_getWindowClientAPI win = do - a <- GLFW.getWindowClientAPI win - a @?= GLFW.ClientAPI'OpenGL - -test_window_context_version :: GLFW.Window -> IO () -test_window_context_version win = do - v0 <- GLFW.getWindowContextVersionMajor win - v1 <- GLFW.getWindowContextVersionMinor win - assertBool "" $ all (`between` (0, 20)) [v0, v1] - -test_getWindowContextRobustness :: GLFW.Window -> IO () -test_getWindowContextRobustness win = do - _ <- GLFW.getWindowContextRobustness win - return () - -test_getWindowOpenGLForwardCompat :: GLFW.Window -> IO () -test_getWindowOpenGLForwardCompat win = do - _ <- GLFW.getWindowOpenGLForwardCompat win - return () - -test_getWindowOpenGLDebugContext :: GLFW.Window -> IO () -test_getWindowOpenGLDebugContext win = do - _ <- GLFW.getWindowOpenGLDebugContext win - return () - -test_getWindowOpenGLProfile :: GLFW.Window -> IO () -test_getWindowOpenGLProfile win = do - _ <- GLFW.getWindowOpenGLProfile win - return () - -test_pollEvents :: IO () -test_pollEvents = - GLFW.pollEvents - -test_waitEvents :: IO () -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 () -test_cursor_input_mode win = do - modes' <- mapM setGet modes - modes' @?= modes - where - modes = - [ GLFW.CursorInputMode'Disabled - , GLFW.CursorInputMode'Hidden - , GLFW.CursorInputMode'Normal - ] - setGet m = do - GLFW.setCursorInputMode win m - GLFW.getCursorInputMode win - -test_sticky_keys_input_mode :: GLFW.Window -> IO () -test_sticky_keys_input_mode win = do - modes' <- mapM setGet modes - modes' @?= modes - where - modes = - [ GLFW.StickyKeysInputMode'Enabled - , GLFW.StickyKeysInputMode'Disabled - ] - setGet m = do - GLFW.setStickyKeysInputMode win m - GLFW.getStickyKeysInputMode win - -test_sticky_mouse_buttons_input_mode :: GLFW.Window -> IO () -test_sticky_mouse_buttons_input_mode win = do - modes' <- mapM setGet modes - modes' @?= modes - where - modes = - [ GLFW.StickyMouseButtonsInputMode'Enabled - , GLFW.StickyMouseButtonsInputMode'Disabled - ] - setGet m = do - GLFW.setStickyMouseButtonsInputMode win m - GLFW.getStickyMouseButtonsInputMode win - -test_joystickPresent :: IO () -test_joystickPresent = do - _ <- GLFW.joystickPresent GLFW.Joystick'1 - r <- GLFW.joystickPresent GLFW.Joystick'16 - assertBool "" $ not r - -test_getJoystickAxes :: IO () -test_getJoystickAxes = - mapM_ GLFW.getJoystickAxes joysticks - -test_getJoystickButtons :: IO () -test_getJoystickButtons = - mapM_ GLFW.getJoystickButtons joysticks - -test_getJoystickName :: IO () -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 () -test_getTime = do - mt <- GLFW.getTime - case mt of - Nothing -> assertFailure "" - Just t -> assertBool "" $ t `between` (0, 10) - -test_setTime :: IO () -test_setTime = do - let t = 37 - GLFW.setTime t - mt <- GLFW.getTime - case mt of - 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 () -test_getCurrentContext win = do - mwin <- GLFW.getCurrentContext - case mwin of - Nothing -> assertFailure "" - Just win' -> win' @?= win - -test_swapBuffers :: GLFW.Window -> IO () -test_swapBuffers = - GLFW.swapBuffers - -test_swapInterval :: IO () -test_swapInterval = - GLFW.swapInterval 1 - -test_extensionSupported :: IO () -test_extensionSupported = do - b0 <- GLFW.extensionSupported "GL_ARB_multisample" - b0 @?= True - b1 <- GLFW.extensionSupported "bogus" - b1 @?= False - --------------------------------------------------------------------------------- - -test_clipboard :: GLFW.Window -> IO () -test_clipboard win = do - rs <- mapM setGet ss - rs @?= map Just ss - where - ss = - [ "abc 123 ???" - , "xyz 456 !!!" - ] - setGet s = do - GLFW.setClipboardString win s - giveItTime - result <- GLFW.getClipboardString win - - err <- GLFW.getError - return $ case err of - Just (GLFW.Error'FormatUnavailable, _) -> Just s - _ -> result - --------------------------------------------------------------------------------- - -{-# ANN module "HLint: ignore Use camelCase" #-} +-- 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) + +-- test-framework +import Test.Framework (Test, defaultMain, testGroup) + +-- test-framework-hunit +import Test.Framework.Providers.HUnit (testCase) + +-- GLFW-b +import qualified Graphics.UI.GLFW as GLFW + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + 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 + GLFW.destroyWindow win + GLFW.terminate + +-------------------------------------------------------------------------------- + +versionMajor, versionMinor, versionRevision :: Int +versionMajor = 3 +versionMinor = 3 +versionRevision = 9 + +giveItTime :: IO () +giveItTime = threadDelay 500000 + +joysticks :: [GLFW.Joystick] +joysticks = + [ GLFW.Joystick'1 + , GLFW.Joystick'2 + , GLFW.Joystick'3 + , GLFW.Joystick'4 + , GLFW.Joystick'5 + , GLFW.Joystick'6 + , GLFW.Joystick'7 + , GLFW.Joystick'8 + , GLFW.Joystick'9 + , GLFW.Joystick'10 + , GLFW.Joystick'11 + , GLFW.Joystick'12 + , GLFW.Joystick'13 + , GLFW.Joystick'14 + , GLFW.Joystick'15 + , GLFW.Joystick'16 + ] + +between :: Ord a => a -> (a,a) -> Bool +between n (l,h) = n >= l && n <= h + +videoModeLooksValid :: GLFW.VideoMode -> Bool +videoModeLooksValid vm = and + [ GLFW.videoModeWidth vm `between` (0,4000) + , GLFW.videoModeHeight vm `between` (0,3000) + , GLFW.videoModeRedBits vm `between` (0, 32) + , GLFW.videoModeGreenBits vm `between` (0, 32) + , GLFW.videoModeBlueBits vm `between` (0, 32) + , GLFW.videoModeRefreshRate vm `between` (0, 120) + ] + +-------------------------------------------------------------------------------- + +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" + [ 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" + [ 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" + [ 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" + [ glfwTest "getTime" test_getTime + , glfwTest "setTime" test_setTime + , glfwTest "getTimerValue" test_getTimerValue + , glfwTest "getTimerFrequency" test_getTimerFrequency + ] + , testGroup "Context" + [ glfwTest "getCurrentContext" $ test_getCurrentContext win + , glfwTest "swapBuffers" $ test_swapBuffers win + , glfwTest "swapInterval" test_swapInterval + , glfwTest "extensionSupported" test_extensionSupported + ] + , testGroup "Clipboard" + [ glfwTest "clipboard" $ test_clipboard win + ] + ] + +-------------------------------------------------------------------------------- + +test_getVersion :: IO () +test_getVersion = do + v <- GLFW.getVersion + GLFW.versionMajor v @?= versionMajor + GLFW.versionMinor v @?= versionMinor + GLFW.versionRevision v @?= versionRevision + +test_getVersionString :: IO () +test_getVersionString = do + mvs <- GLFW.getVersionString + case mvs of + Just vs -> assertBool "" $ v `isPrefixOf` vs + Nothing -> assertFailure "" + 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 + case r of + Just ms -> assertBool "" $ (not . null) ms + Nothing -> assertFailure "" + +test_getPrimaryMonitor :: IO () +test_getPrimaryMonitor = do + r <- GLFW.getPrimaryMonitor + case r of + Just _ -> return () + Nothing -> assertFailure "" + +test_getMonitorPos :: GLFW.Monitor -> IO () +test_getMonitorPos mon = do + (x, y) <- GLFW.getMonitorPos mon + assertBool "" $ x >= 0 + assertBool "" $ y >= 0 + +test_getMonitorPhysicalSize :: GLFW.Monitor -> IO () +test_getMonitorPhysicalSize mon = do + (w, h) <- GLFW.getMonitorPhysicalSize mon + 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 -> assertBool "" $ all isAscii name + +test_getVideoModes :: GLFW.Monitor -> IO () +test_getVideoModes mon = do + mvms <- GLFW.getVideoModes mon + case mvms of + Nothing -> assertFailure "" + Just vms -> assertBool "" $ all videoModeLooksValid vms + +test_getVideoMode :: GLFW.Monitor -> IO () +test_getVideoMode mon = do + mvm <- GLFW.getVideoMode mon + case mvm of + Just vm -> assertBool "" $ videoModeLooksValid vm + Nothing -> assertFailure "" + +test_getGammaRamp :: GLFW.Monitor -> IO () +test_getGammaRamp mon = do + mgr <- GLFW.getGammaRamp mon + case mgr of + Nothing -> assertFailure "" + Just gr -> assertBool "" $ + let rsl = length $ GLFW.gammaRampRed gr + gsl = length $ GLFW.gammaRampGreen gr + bsl = length $ GLFW.gammaRampBlue gr + in rsl > 0 && rsl == gsl && gsl == bsl + +-------------------------------------------------------------------------------- + +test_defaultWindowHints :: IO () +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 + r0 @?= False + + GLFW.setWindowShouldClose win True + r1 <- GLFW.windowShouldClose win + r1 @?= True + + GLFW.setWindowShouldClose win False + 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" + +-- This is a little strange. Depending on your window manager, etc, after +-- setting the window position to (x,y), the actual new window position might +-- be (x+5,y+5) due to borders. So we just check for consistency. +test_window_pos :: GLFW.Window -> IO () +test_window_pos win = do + let x = 17 + y = 37 + xoff = 53 + yoff = 149 + (x0, y0, dx0, dy0) <- setGet x y + (x1, y1, dx1, dy1) <- setGet (x+xoff) (y+yoff) + dx0 @?= dx1 + dy0 @?= dy1 + x1 - x0 @?= xoff + y1 - y0 @?= yoff + where + setGet x0 y0 = do + GLFW.setWindowPos win x0 y0 + giveItTime + (x1, y1) <- GLFW.getWindowPos win + let (dx, dy) = (x0-x1, y0-y1) + return (x1, y1, dx, dy) + +test_window_size :: GLFW.Window -> IO () +test_window_size win = do + 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 + (fw, fh) <- GLFW.getFramebufferSize win + -- Window size and framebuffer size are not always equal, an example are + -- retina screens. But maybe it's safe to assume they'll always be scaled + -- equally in both dimensions? + let ww = ( fromIntegral fw / fromIntegral w ) :: Double + hh = ( fromIntegral fh / fromIntegral h ) :: Double + ww @?= hh + assertBool "" $ fw /= 0 + assertBool "" $ fh /= 0 + +test_iconification :: GLFW.Window -> IO () +test_iconification win = do + GLFW.showWindow win + is0 <- GLFW.getWindowIconified win + is0 @?= False + + GLFW.iconifyWindow win + giveItTime + is1 <- GLFW.getWindowIconified win + is1 @?= True + + GLFW.restoreWindow win + GLFW.hideWindow win + +-- test_show_hide :: GLFW.Window -> IO () +-- test_show_hide win = do +-- v0 <- GLFW.getWindowVisible win +-- v0 @?= True + +-- GLFW.hideWindow win +-- giveItTime +-- v1 <- GLFW.getWindowVisible win +-- v1 @?= False + +-- GLFW.showWindow win +-- giveItTime +-- v2 <- GLFW.getWindowVisible win +-- v2 @?= True + +test_getWindowMonitor :: GLFW.Window -> GLFW.Monitor -> IO () +test_getWindowMonitor win _ = do + 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 + 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 @?= False + +test_getWindowResizable :: GLFW.Window -> IO () +test_getWindowResizable win = do + b <- GLFW.getWindowResizable win + b @?= True + +test_getWindowDecorated :: GLFW.Window -> IO () +test_getWindowDecorated win = do + b <- GLFW.getWindowDecorated win + b @?= True + +test_getWindowClientAPI :: GLFW.Window -> IO () +test_getWindowClientAPI win = do + a <- GLFW.getWindowClientAPI win + a @?= GLFW.ClientAPI'OpenGL + +test_window_context_version :: GLFW.Window -> IO () +test_window_context_version win = do + v0 <- GLFW.getWindowContextVersionMajor win + v1 <- GLFW.getWindowContextVersionMinor win + assertBool "" $ all (`between` (0, 20)) [v0, v1] + +test_getWindowContextRobustness :: GLFW.Window -> IO () +test_getWindowContextRobustness win = do + _ <- GLFW.getWindowContextRobustness win + return () + +test_getWindowOpenGLForwardCompat :: GLFW.Window -> IO () +test_getWindowOpenGLForwardCompat win = do + _ <- GLFW.getWindowOpenGLForwardCompat win + return () + +test_getWindowOpenGLDebugContext :: GLFW.Window -> IO () +test_getWindowOpenGLDebugContext win = do + _ <- GLFW.getWindowOpenGLDebugContext win + return () + +test_getWindowOpenGLProfile :: GLFW.Window -> IO () +test_getWindowOpenGLProfile win = do + _ <- GLFW.getWindowOpenGLProfile win + return () + +test_pollEvents :: IO () +test_pollEvents = + GLFW.pollEvents + +test_waitEvents :: IO () +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 () +test_cursor_input_mode win = do + modes' <- mapM setGet modes + modes' @?= modes + where + modes = + [ GLFW.CursorInputMode'Disabled + , GLFW.CursorInputMode'Hidden + , GLFW.CursorInputMode'Normal + ] + setGet m = do + GLFW.setCursorInputMode win m + GLFW.getCursorInputMode win + +test_sticky_keys_input_mode :: GLFW.Window -> IO () +test_sticky_keys_input_mode win = do + modes' <- mapM setGet modes + modes' @?= modes + where + modes = + [ GLFW.StickyKeysInputMode'Enabled + , GLFW.StickyKeysInputMode'Disabled + ] + setGet m = do + GLFW.setStickyKeysInputMode win m + GLFW.getStickyKeysInputMode win + +test_sticky_mouse_buttons_input_mode :: GLFW.Window -> IO () +test_sticky_mouse_buttons_input_mode win = do + modes' <- mapM setGet modes + modes' @?= modes + where + modes = + [ GLFW.StickyMouseButtonsInputMode'Enabled + , GLFW.StickyMouseButtonsInputMode'Disabled + ] + setGet m = do + GLFW.setStickyMouseButtonsInputMode win m + GLFW.getStickyMouseButtonsInputMode win + +test_joystickPresent :: IO () +test_joystickPresent = do + _ <- GLFW.joystickPresent GLFW.Joystick'1 + r <- GLFW.joystickPresent GLFW.Joystick'16 + assertBool "" $ not r + +test_getJoystickAxes :: IO () +test_getJoystickAxes = + mapM_ GLFW.getJoystickAxes joysticks + +test_getJoystickButtons :: IO () +test_getJoystickButtons = + mapM_ GLFW.getJoystickButtons joysticks + +test_getJoystickName :: IO () +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 () +test_getTime = do + mt <- GLFW.getTime + case mt of + Nothing -> assertFailure "" + Just t -> assertBool "" $ t `between` (0, 10) + +test_setTime :: IO () +test_setTime = do + let t = 37 + GLFW.setTime t + mt <- GLFW.getTime + case mt of + 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 () +test_getCurrentContext win = do + mwin <- GLFW.getCurrentContext + case mwin of + Nothing -> assertFailure "" + Just win' -> win' @?= win + +test_swapBuffers :: GLFW.Window -> IO () +test_swapBuffers = + GLFW.swapBuffers + +test_swapInterval :: IO () +test_swapInterval = + GLFW.swapInterval 1 + +test_extensionSupported :: IO () +test_extensionSupported = do + b0 <- GLFW.extensionSupported "GL_ARB_multisample" + b0 @?= True + b1 <- GLFW.extensionSupported "bogus" + b1 @?= False + +-------------------------------------------------------------------------------- + +test_clipboard :: GLFW.Window -> IO () +test_clipboard win = do + rs <- mapM setGet ss + rs @?= map Just ss + where + ss = + [ "abc 123 ???" + , "xyz 456 !!!" + ] + setGet s = do + GLFW.setClipboardString win s + giveItTime + result <- GLFW.getClipboardString win + + err <- GLFW.getError + return $ case err of + Just (GLFW.Error'FormatUnavailable, _) -> Just s + _ -> result + +-------------------------------------------------------------------------------- + +{-# ANN module "HLint: ignore Use camelCase" #-}