sdl2 2.1.3.1 → 2.5.6.0
raw patch · 42 files changed
Files
- ChangeLog.md +191/−0
- bench/Space.hs +337/−0
- cbits/sdlhelper.c +21/−0
- examples/AudioExample.hs +4/−4
- examples/EventWatch.hs +65/−0
- examples/OpenGLExample.hs +1/−1
- examples/RenderGeometry.hs +123/−0
- examples/UserEvents.hs +65/−0
- examples/lazyfoo/Lesson02.hs +2/−1
- examples/lazyfoo/Lesson03.hs +1/−1
- examples/lazyfoo/Lesson04.hs +1/−1
- examples/lazyfoo/Lesson12.hs +3/−3
- examples/twinklebear/Lesson05.hs +6/−3
- include/sdlhelper.h +2/−0
- sdl2.cabal +120/−14
- src/SDL.hs +13/−6
- src/SDL/Audio.hs +14/−14
- src/SDL/Event.hs +413/−214
- src/SDL/Exception.hs +0/−62
- src/SDL/Filesystem.hs +1/−1
- src/SDL/Hint.hs +2/−2
- src/SDL/Init.hs +1/−4
- src/SDL/Input/GameController.hs +332/−0
- src/SDL/Input/Joystick.hs +84/−13
- src/SDL/Input/Keyboard.hs +7/−7
- src/SDL/Input/Keyboard/Codes.hs +6/−0
- src/SDL/Input/Mouse.hs +179/−52
- src/SDL/Internal/Exception.hs +77/−0
- src/SDL/Internal/Types.hs +5/−0
- src/SDL/Internal/Vect.hs +3/−3
- src/SDL/Power.hs +1/−1
- src/SDL/Raw/Audio.hs +18/−0
- src/SDL/Raw/Enum.hsc +146/−0
- src/SDL/Raw/Event.hs +109/−1
- src/SDL/Raw/Timer.hs +16/−0
- src/SDL/Raw/Types.hsc +132/−27
- src/SDL/Raw/Video.hs +201/−1
- src/SDL/Time.hs +20/−6
- src/SDL/Video.hs +143/−75
- src/SDL/Video/OpenGL.hs +15/−10
- src/SDL/Video/Renderer.hs +372/−120
- src/SDL/Video/Vulkan.hs +110/−0
ChangeLog.md view
@@ -1,3 +1,194 @@+2.5.6.0+=======++* Added game controller helper functions: `isGameController`, `mkControllerDevice`, `mkControllerDevice'`, `controllerFromInstanceID`+* Added raw bindings for player index, LED control, rumble triggers, and touchpad query functions+* Added `JoystickIndex` type alias for clarity+* `getControllerID` now returns `Raw.JoystickID` for improved type documentation+* Fixed `controllerDeviceEventWhich` documentation to clarify index vs instance ID semantics++2.5.5.1+=======++* Added `getTicks64`+* Added `rendererIntegerScale`+* Added unboxed Vector instances for Rectangle+* Updated dependency ranges++2.5.5.0+=======++* Added `windowOpacity` property+* Added `renderGeometry` and `renderGeometryRaw`+ - Requires SDL 2.0.18+ - See `examples/RenderGeometry.hs`+* Changed `SDL.Input.GameController` bindings to be more high-level+ - `ControllerAxisEventData` type changed++2.5.4.0+=======++* Added missing floating point variants of render functions.+* Fixed `createCursor` masks.+* Adapted `createCursorFrom` helper from LambdaHack[1].+* Added `pkgconfig` flag (enabled by default) to make its use optional.++[1]: https://github.com/LambdaHack/LambdaHack/blob/7ed94b4b6c75fc46afeef01d8ac476c4598fb822/engine-src/Game/LambdaHack/Client/UI/Frontend/Sdl.hs#L421-L455++2.5.3.3+=======++* Alignment in hsc files is now provided by hsc2c.++2.5.3.2+=======++* Added high-level binding for `setWindowIcon`.+* Raised `text` upper bound to 2.0.+* Fixed and optimized even polling for SDL 2.0.20.+* `copyExF` and related are under a package flag now.+ Turn on `recent-ish` if you have at least 2.0.10.+* Removed misleading result type from `updateTexture`.++2.5.3.1+=======++* Constructors exported for ModalLocation, SurfacePixelFormat, AudioSpec.+* Added getWindowBordersSize.+* Added SDL.Input.Mouse.createSystemCursor.+++2.5.3.0+=======++* Correct the Storable instance for SDL.Raw.Types.Event to correctly convert+ SDL_CONTROLLERAXISMOTION to a ControllerAxisEvent (it was previously+ ControllerButtonEvent). See https://github.com/haskell-game/sdl2/pull/218 for+ more details.++2.5.2.0+=======++* Correct SDL.Raw.Video.vkLoadLibrary to correctly call vkLoadLibraryFFI, rather+ than setClipboardTextFFI. See https://github.com/haskell-game/sdl2/pull/209.++2.5.1.0+=======++* Support `linear-1.21`+++2.5.0.0+=======++* Version 2.0.6 of the SDL2 C library is now required.++* Added Vulkan support. See `SDL.Video.WindowGraphicsContext` data type and `SDL.Video.Vulkan` module.++* Support `StateVar` < 1.3+++2.4.1.0+=======++* More SDL functions no longer allocate. See+ https://github.com/haskell-game/sdl2/pull/179 and+ https://github.com/haskell-game/sdl2/issues/178. Thanks to @chrisdone for this+ work.+++* Fixed an off-by-one bug in `SDL.Input.Mouse.getMouseButtons`. See+ https://github.com/haskell-game/sdl2/pull/177 for more information. Thanks to+ @Linearity for identifying and fixing this bug.+++2.4.0.1+=======+* Raise upper bounds for `exceptions` to <0.11+++2.4.0+=====+* `getRelativeMouseLocation` now returns `Vector` instead of `Point`.+* `getModalMouseLocation` returns either a `Vector` or a `Point`, wrapped in (new) `ModalLocation`.+* `WindowSizeChangedEventData` includes the new window size.+* Added an invalid state to the `ControllerButtonState` enum, and switched to a more reliable state detection method.+* Raise upper bounds for `exceptions` to <0.10+++2.3.0+=====++* Windows builds now use `-D_SDL_main_h`. See https://github.com/haskell-game/sdl2/issues/139 for more discussion.+* Some basic support for game controller events have been added. See `SDL.Input.GameController` and changes to `ControllerDeviceEventData`.+* Support for event watching: `addEventWatch` and `delEventWatch`.+* High-level bindings now distinguish between finger down / motion / up.+ See `SDL.Event.TouchFingerEvent` and `SDL.Event.TouchFingerMotionEvent`.+* Several event payloads now have their `Window` fields modified to use `Maybe Window`, substituting `Nothing` for null pointers.+* High-level structure for controller button state: `ControllerButtonState`.+* High-level structure for controller buttons: `ControllerButton`.+* High-level structure for controller connection: `ControllerDeviceConnection`.+* High-level structure for joystick device connection: `JoyDeviceConnection`.+* High-level structure for joystick button state: `JoyButtonState`.+* Support for user defined events: `registerEvent`, `pushRegisteredEvent`, and `getRegisteredEvent`.+* Initial window visibility can be specified in `WindowConfig` for `createWindow` function.+* `WarpMouseOrigin` is now fully exported and can warp to global coordinates.+* It's possible to retrieve palette information with `paletteNColors`, `paletteColors` and `palletColor`.+++2.2.0+=====++* Version 2.0.4 of the SDL2 C library is now required:+ * `SDL.Event`:+ * Add `AudioDeviceEvent` constructor to `Event`+ * Add `KeymapChangedEvent` constructor to `EventPayload`+ * Add `mouseWheelEventDirection` field to `MouseWheelEventData`+ * `SDL.Input.Mouse`:+ * Add `MouseScrollDirection` enumeration+ * `SDL.Raw.Audio`:+ * Add `clearQueuedAudio` function+ * Add `getQueuedAudioSize` function+ * Add `queueAudio` function+ * `SDL.Raw.Enum`:+ * Add `SDL_GL_CONTEXT_RELEASE_BEHAVIOR` pattern synonym+ * Add `JoystickPowerLevel` pattern synonyms+ * Add `SDL_MOUSEWHEEL_NORMAL` and `SDL_MOUSEWHEEL_FLIPPED` pattern synonyms+ * Add `SDL_KEYMAPCHANGED`, `SDL_AUDIODEVICEADDED`, `SDL_AUDIODEVICEREMOVED`,+ `SDL_RENDER_TARGETS_RESET`, and `SDL_RENDER_DEVICE_RESET` pattern synonyms+ * Add `SDL_GL_CONTEXT_RELEASE_BEHAVIOR_NONE` and+ `SDL_GL_CONTEXT_RELEASE_BEHAVIOR_FLUSH` pattern synonyms+ * Add `SDL_WINDOW_MOUSE_CAPTURE` pattern synonym+ * `SDL.Raw.Event`:+ * Add `captureMouse` function+ * Add `getGlobalMouseState` function+ * Add `warpMouseGlobal` function+ * Add `joystickCurrentPowerLevel` function+ * Add `joystickFromInstanceID` function+ * Add `gameControllerFromInstanceID` function+ * `SDL.Raw.Event`:+ * Add `AudioDeviceEvent` constructor to `Event`+ * Add `KeymapChangedEvent` constructor to `Event`+ * Add `mouseWheelEventDirection` field to `MouseMotionEvent` constructor++* Add `SDL.Exception` module, exposing `SDLException`+* Add new function, `createSoftwareRenderer`, to render onto a surface+* Add joystick POV hat support+* Remove deprecated functionality:+ * `InitEverything` enumeration in `SDL.Init`+ * `mapRGB` in `SDL.Video.Renderer`+ * `setRelativeMouseMode` in `SDL.Input.Mouse`+ * `getRelativeMouseMode` in `SDL.Input.Mouse`+ * `getMouseLocation` in `SDL.Input.Mouse`+* Remove `ClipboardUpdateEventData`+* Merge `isScreenSaverEnabled`, `enableScreenSaver`, and `disableScreenSaver`+ into a `screenSaverEnabled` StateVar.+* Make function `surfaceBlit` in `SDL.Video.Renderer` return final blit+ rectangle post-clipping.+* Make all fields in EventData constructors strict+* Fix issue with `setWindowMode` transitions not working properly between+ fullscreen and windowed modes.+ 2.1.3.1 =======
+ bench/Space.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Test that space usage is low and avoid GCs where possible.++module Main where++import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Storable.Mutable as SVM+import Foreign.C (CInt)+import Foreign.Ptr+import Foreign.Storable+import SDL+import Weigh++-- | Main entry point.+main :: IO ()+main =+ mainWith+ (do setColumns [Case, Allocated, GCs]+ wgroup+ "pollEvent"+ (sequence_+ [ validateAction+ ("pollEvent " ++ show i)+ pollEventTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 2000+ then Just+ "Allocated >2KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000, 10000]+ ])+ wgroup+ "pollEvent+clear"+ (sequence_+ [ validateAction+ ("pollEvent + clear " ++ show i)+ pollEventClearTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 4000+ then Just+ "Allocated >4KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000, 10000]+ ])+ wgroup+ "pollEvent+present"+ (sequence_+ [ validateAction+ ("pollEvent + present " ++ show i)+ pollEventPresentTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 4000+ then Just+ "Allocated >4KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000]+ ])+ wgroup+ "pollEvent+drawColor"+ (sequence_+ [ validateAction+ ("pollEvent + drawColor " ++ show i)+ pollEventDrawColorTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 4000+ then Just+ "Allocated >KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000, 2000]+ ])+ wgroup+ "pollEvent+drawRect"+ (sequence_+ [ validateAction+ ("pollEvent + drawRect " ++ show i)+ pollEventDrawRectTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 4000+ then Just+ "Allocated >4KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000]+ ])+ wgroup+ "animated rect"+ (sequence_+ [ validateAction+ ("animated rect " ++ show i)+ pollEventAnimRectTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 4000+ then Just+ "Allocated >4KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000, 2000]+ ])+ wgroup+ "animated rects"+ (sequence_+ [ validateAction+ ("animated rects " ++ show i)+ pollEventAnimRectsTest+ i+ (\weight ->+ if weightGCs weight > 0+ then Just "Non-zero number of garbage collections!"+ else if weightAllocatedBytes weight > 5000+ then Just+ "Allocated >4KB! Allocations should be constant."+ else Nothing)+ | i <- [1, 10, 100, 1000, 2000, 3000]+ ]))++-- | Test that merely polling does not allocate or engage the GC.+-- <https://github.com/haskell-game/sdl2/issues/178>+pollEventTest :: Int -> IO ()+pollEventTest iters = do+ initializeAll+ let go :: Int -> IO ()+ go 0 = pure ()+ go i = do+ _ <- pollEvent+ go (i - 1)+ go iters++-- | Test that merely polling and clearing the screen does not+-- allocate or engage the GC.+pollEventClearTest :: Int -> IO ()+pollEventClearTest iters = do+ initializeAll+ window <- createWindow "pollEventClearTest" defaultWindow+ renderer <- createRenderer window (-1) defaultRenderer+ let go :: Int -> IO ()+ go 0 = pure ()+ go i = do+ _ <- pollEvent+ clear renderer+ go (i - 1)+ go iters++-- | Test that merely polling and presenting does not allocate or+-- engage the GC.+pollEventPresentTest :: Int -> IO ()+pollEventPresentTest iters = do+ initializeAll+ window <- createWindow "pollEventPresentTest" defaultWindow+ renderer <- createRenderer window (-1) defaultRenderer+ let go :: Int -> IO ()+ go 0 = pure ()+ go i = do+ _ <- pollEvent+ clear renderer+ present renderer+ go (i - 1)+ go iters++-- | Test that merely polling and drawColoring does not allocate or+-- engage the GC.+pollEventDrawColorTest :: Int -> IO ()+pollEventDrawColorTest iters = do+ initializeAll+ window <- createWindow "pollEventDrawColorTest" defaultWindow+ renderer <- createRenderer window (-1) defaultRenderer+ let go :: Int -> IO ()+ go 0 = pure ()+ go i = do+ _ <- pollEvent+ rendererDrawColor renderer $= V4 0 0 255 255+ clear renderer+ present renderer+ go (i - 1)+ go iters++-- | Draw a rectangle on screen.+pollEventDrawRectTest :: Int -> IO ()+pollEventDrawRectTest iters = do+ initializeAll+ window <- createWindow "pollEventDrawRectTest" defaultWindow+ renderer <- createRenderer window (-1) defaultRenderer+ let go :: Int -> IO ()+ go 0 = pure ()+ go i = do+ _ <- pollEvent+ rendererDrawColor renderer $= V4 40 40 40 255+ clear renderer+ rendererDrawColor renderer $= V4 255 255 255 255+ fillRect renderer (Just (Rectangle (P (V2 40 40)) (V2 80 80)))+ present renderer+ go (i - 1)+ go iters++--------------------------------------------------------------------------------+-- Animated rect test++data State = State+ { stateI :: !CInt+ , stateV :: !(V2 CInt)+ , stateP :: !(V2 CInt)+ }++-- | Animate a rectangle on the screen for n iterations.+pollEventAnimRectTest :: CInt -> IO ()+pollEventAnimRectTest iters = do+ initializeAll+ window <-+ createWindow+ "pollEventAnimRectTest"+ defaultWindow {windowInitialSize = defaultWindowSize}+ renderer <- createRenderer window (-1) defaultRenderer+ let go :: State -> IO ()+ go !(State 0 _ _) = pure ()+ go !(State i (V2 xv yv) p@(V2 x y)) = do+ _ <- pollEvent+ rendererDrawColor renderer $= V4 40 40 40 255+ clear renderer+ rendererDrawColor renderer $= V4 255 255 255 255+ let xv'+ | x + w > mw = -xv+ | x < 0 = -xv+ | otherwise = xv+ yv'+ | y + h > mh = -yv+ | y < 0 = -yv+ | otherwise = yv+ v' = V2 xv' yv'+ p' = p + v'+ fillRect renderer (Just (Rectangle (P p') (V2 w h)))+ present renderer+ go (State (i - 1) v' p')+ go (State iters (V2 2 1) (V2 0 0))+ where+ defaultWindowSize :: V2 CInt+ defaultWindowSize = V2 800 600+ mw :: CInt+ mh :: CInt+ V2 mw mh = defaultWindowSize+ w :: CInt+ h :: CInt+ (w, h) = (100, 100)++--------------------------------------------------------------------------------+-- Animated rects test++data Square = Square+ { squareV :: !(V2 CInt)+ , squareP :: !(V2 CInt)+ }++instance Storable Square where+ sizeOf _ = sizeOf (undefined :: V2 CInt) * 2+ alignment _ = 1+ poke ptr (Square x y) = do+ poke (castPtr ptr) x+ poke (plusPtr ptr (sizeOf x)) y+ peek ptr = do+ x <- peek (castPtr ptr)+ y <- peek (plusPtr ptr (sizeOf x))+ pure (Square x y)++-- | Animate a rectangle on the screen for n iterations.+pollEventAnimRectsTest :: CInt -> IO ()+pollEventAnimRectsTest iters = do+ initializeAll+ window <-+ createWindow+ "pollEventAnimRectsTest"+ defaultWindow {windowInitialSize = defaultWindowSize}+ renderer <- createRenderer window (-1) defaultRenderer+ squares <-+ SV.unsafeThaw+ (SV.fromList+ [ Square (V2 2 1) (V2 0 0)+ , Square (V2 3 2) (V2 300 200)+ , Square (V2 1 1) (V2 100 500)+ , Square (V2 1 1) (V2 400 100)+ , Square (V2 1 2) (V2 200 400)+ , Square (V2 2 1) (V2 250 0)+ , Square (V2 1 2) (V2 300 500)+ , Square (V2 1 2) (V2 230 100)+ , Square (V2 1 1) (V2 200 490)+ ])+ let go :: CInt -> IO ()+ go !0 = pure ()+ go !i = do+ _ <- pollEvent+ rendererDrawColor renderer $= V4 40 40 40 255+ clear renderer+ rendererDrawColor renderer $= V4 255 255 255 255+ let animateSquare si = do+ Square (V2 xv yv) p@(V2 x y) <- SVM.read squares si+ let xv'+ | x + w > mw = -xv+ | x < 0 = -xv+ | otherwise = xv+ yv'+ | y + h > mh = -yv+ | y < 0 = -yv+ | otherwise = yv+ v' = V2 xv' yv'+ p' = p + v'+ SVM.write squares si (Square v' p')+ fillRect renderer (Just (Rectangle (P p') (V2 w h)))+ let loop 0 = pure ()+ loop si = animateSquare si>>loop (si-1)+ loop (SVM.length squares - 1)+ present renderer+ go (i - 1)+ go iters+ where+ defaultWindowSize :: V2 CInt+ defaultWindowSize = V2 800 600+ mw :: CInt+ mh :: CInt+ V2 mw mh = defaultWindowSize+ w :: CInt+ h :: CInt+ (w, h) = (100, 100)
cbits/sdlhelper.c view
@@ -1,6 +1,17 @@ #include <string.h>+#include <stdlib.h> #include "sdlhelper.h" +int SDLHelper_GetEventBufferSize() { return 64; }+SDL_Event *SDLHelper_GetEventBuffer() {+ static SDL_Event *buffer = NULL;+ if(buffer == NULL) {+ /* leak an inconsequental amount of memory */+ buffer = calloc(SDLHelper_GetEventBufferSize(), sizeof(SDL_Event));+ }+ return buffer;+}+ void SDLHelper_JoystickGetDeviceGUID (int device_index, SDL_JoystickGUID *guid) { SDL_JoystickGUID t = SDL_JoystickGetDeviceGUID (device_index);@@ -74,4 +85,14 @@ int SDLHelper_SetError (const char *str) { return SDL_SetError ("%s", str);+}++int SDLHelper_RenderFillRectEx(SDL_Renderer* renderer, int x, int y, int w, int h)+{+ SDL_Rect rect;+ rect.x=x;+ rect.y=y;+ rect.w=w;+ rect.h=h;+ return SDL_RenderFillRect(renderer,&rect); }
examples/AudioExample.hs view
@@ -5,7 +5,7 @@ import Data.IORef import Control.Monad import Control.Concurrent-import Data.Int (Int16)+import Data.Int (Int16, Int32) import SDL import qualified Data.Vector.Storable.Mutable as V @@ -13,9 +13,9 @@ sinSamples = map (\n -> let t = fromIntegral n / 48000 :: Double- freq = 440 * 4- in round (fromIntegral (maxBound `div` 2 :: Int16) * sin (t * freq)))- [0 :: Int16 ..]+ freq = 440+ in round (fromIntegral (maxBound `div` 2 :: Int16) * sin (2 * pi * freq * t)))+ [0 :: Int32 ..] audioCB :: IORef [Int16] -> AudioFormat sampleType -> V.IOVector sampleType -> IO () audioCB samples format buffer =
+ examples/EventWatch.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++{-|++The following example shows how setting a watch for the WindowSizeChangedEvent+allows us to handle the events as they are generated. Handling them in the+event loop, on the other hand, only allows us to see a final, coalesced, event.++To demonstrate this, run the program, resize the window with your mouse,+and check your console output.++-}+module EventWatch where++import SDL++import Control.Monad (void)++main :: IO ()+main = do+ initializeAll+ window <- createWindow "resize" WindowConfig {+ windowBorder = True+ , windowHighDPI = False+ , windowInputGrabbed = False+ , windowMode = Windowed+ , windowGraphicsContext = NoGraphicsContext+ , windowPosition = Wherever+ , windowResizable = True+ , windowInitialSize = V2 800 600+ , windowVisible = True+ }+ _renderer <- createRenderer window (-1) defaultRenderer+ void . addEventWatch $ \ev ->+ case eventPayload ev of+ WindowSizeChangedEvent sizeChangeData ->+ putStrLn $ "eventWatch windowSizeChanged: " ++ show sizeChangeData+ _ -> return ()+ appLoop++appLoop :: IO ()+appLoop = waitEvent >>= go+ where+ go :: Event -> IO ()+ go ev =+ case eventPayload ev of+ WindowSizeChangedEvent sizeChangeData -> do+ putStrLn $ "waitEvent windowSizeChanged: " ++ show sizeChangeData+ waitEvent >>= go+ KeyboardEvent keyboardEvent+ | keyboardEventKeyMotion keyboardEvent == Pressed &&+ keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ+ -> return ()+ KeyboardEvent keyboardEvent+ | keyboardEventKeyMotion keyboardEvent == Pressed+ -> print (keyboardEventKeysym keyboardEvent) >> waitEvent >>= go+ MouseMotionEvent mouseMotionEvent+ -> print mouseMotionEvent >> waitEvent >>= go+ MouseButtonEvent mouseButtonEvent+ -> print mouseButtonEvent >> waitEvent >>= go+ MouseWheelEvent mouseWheelEvent+ -> print mouseWheelEvent >> waitEvent >>= go+ QuitEvent+ -> return ()+ _ -> waitEvent >>= go
examples/OpenGLExample.hs view
@@ -31,7 +31,7 @@ SDL.createWindow "SDL / OpenGL Example" SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight,- SDL.windowOpenGL = Just SDL.defaultOpenGL}+ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL} SDL.showWindow window _ <- SDL.glCreateContext window
+ examples/RenderGeometry.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}++module RenderGeometry where++import Control.Monad+import Data.Word (Word8)+import Foreign (castPtr, plusPtr, sizeOf)+import Foreign.C.Types+import SDL.Vect+import qualified Data.Vector.Storable as V++import SDL (($=))+import qualified SDL+import SDL.Raw.Types (FPoint(..), Color(..))++screenWidth, screenHeight :: CInt+(screenWidth, screenHeight) = (640, 480)++main :: IO ()+main = do+ SDL.initialize [SDL.InitVideo]+ SDL.HintRenderScaleQuality $= SDL.ScaleLinear+ do renderQuality <- SDL.get SDL.HintRenderScaleQuality+ when (renderQuality /= SDL.ScaleLinear) $+ putStrLn "Warning: Linear texture filtering not enabled!"++ window <-+ SDL.createWindow+ "SDL / RenderGeometry Example"+ SDL.defaultWindow+ { SDL.windowInitialSize = V2 screenWidth screenHeight+ , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL+ }+ SDL.showWindow window++ renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer++ let+ tl = fromIntegral screenWidth * 0.1+ tt = fromIntegral screenHeight * 0.1+ tr = fromIntegral screenWidth * 0.9+ tb = fromIntegral screenHeight * 0.9++ triVertices = V.fromList+ [ SDL.Vertex+ (FPoint tl tb)+ (Color 0xFF 0 0 255)+ (FPoint 0 0)+ , SDL.Vertex+ (FPoint tr tb)+ (Color 0 0xFF 0 255)+ (FPoint 0 1)+ , SDL.Vertex+ (FPoint (tl/2 + tr/2) tt)+ (Color 0 0 0xFF 255)+ (FPoint 1 1)+ ]++ let+ l = fromIntegral screenWidth * 0.2+ t = fromIntegral screenHeight * 0.2+ r = fromIntegral screenWidth * 0.8+ b = fromIntegral screenHeight * 0.8++ quadVertices = V.fromList+ [ SDL.Vertex+ (FPoint l b)+ (Color 0xFF 0 0xFF 127)+ (FPoint 0 0)+ , SDL.Vertex+ (FPoint r b)+ (Color 0xFF 0 0xFF 127)+ (FPoint 1 0)+ , SDL.Vertex+ (FPoint r t)+ (Color 0xFF 0xFF 0 127)+ (FPoint 1 1)+ , SDL.Vertex+ (FPoint l t)+ (Color 0 0 0 127)+ (FPoint 0 1)+ ]+ quadIndices = V.fromList+ [ 0, 1, 3+ , 2, 3, 1+ ]+ stride = fromIntegral $ sizeOf (undefined :: SDL.Vertex)++ let loop = do+ events <- SDL.pollEvents+ let quit = elem SDL.QuitEvent $ map SDL.eventPayload events++ SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound+ SDL.clear renderer++ SDL.renderGeometry+ renderer+ Nothing+ triVertices+ mempty++ SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend+ V.unsafeWith quadVertices $ \ptr ->+ SDL.renderGeometryRaw+ renderer+ Nothing+ (castPtr ptr)+ stride+ (castPtr ptr `plusPtr` sizeOf (undefined :: FPoint))+ stride+ (castPtr ptr `plusPtr` sizeOf (undefined :: FPoint) `plusPtr` sizeOf (undefined :: Color))+ stride+ (fromIntegral $ V.length quadVertices)+ (quadIndices :: V.Vector Word8)++ SDL.present renderer++ unless quit loop++ loop++ SDL.destroyWindow window+ SDL.quit
+ examples/UserEvents.hs view
@@ -0,0 +1,65 @@+module UserEvents where++import Control.Concurrent (myThreadId)+import Control.Monad (void)+import Data.Maybe (Maybe(Nothing))+import Data.Word (Word32)+import qualified Data.Text as Text+import Foreign.Ptr (nullPtr)+import SDL++-- | A timer event with timestamp+data TimerEvent = TimerEvent Word32++timerEvent :: IO TimerEvent+timerEvent = do+ t <- show <$> ticks+ tid <- show <$> myThreadId+ putStrLn $ "Created timer event at " ++ t ++ " ticks. Threadid: " ++ tid+ return $ TimerEvent 0++main :: IO ()+main = do+ initializeAll+ let toTimerEvent _ = return . Just . TimerEvent+ fromTimerEvent = const $ return emptyRegisteredEvent+ registeredEvent <- registerEvent toTimerEvent fromTimerEvent+ case registeredEvent of+ Nothing -> putStrLn "Fatal error: unable to register timer events."+ Just registeredTimerEvent -> do+ void . addTimer 1000 $ mkTimerCb registeredTimerEvent+ putStrLn "press q at any time to quit"+ appLoop registeredTimerEvent++mkTimerCb :: RegisteredEventType TimerEvent -> TimerCallback+mkTimerCb (RegisteredEventType pushTimerEvent _) interval = do+ pushResult <- pushTimerEvent =<< timerEvent+ case pushResult of+ EventPushSuccess -> return ()+ EventPushFiltered -> putStrLn "event push was filtered: this is impossible"+ EventPushFailure e -> putStrLn $ "Couldn't push event: " ++ Text.unpack e+ return $ Reschedule interval++appLoop :: RegisteredEventType TimerEvent -> IO ()+appLoop (RegisteredEventType _pushTimerEvent getTimerEvent) = waitEvent >>= go+ where+ go :: Event -> IO ()+ go ev =+ case eventPayload ev of+ -- Press Q to quit+ KeyboardEvent keyboardEvent+ | keyboardEventKeyMotion keyboardEvent == Pressed &&+ keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ+ -> return ()+ UserEvent _ -> do+ maybeTimerEvent <- getTimerEvent ev+ case maybeTimerEvent of+ Just (TimerEvent ts) -> do+ t <- show <$> ticks+ tid <- show <$> myThreadId+ putStrLn $ "Got timer event from queue at " ++ t ++ " ticks."+ putStrLn $ "Timestamp: " ++ show ts+ putStrLn $ "Threadid: " ++ tid+ Nothing -> return ()+ waitEvent >>= go+ _ -> waitEvent >>= go
examples/lazyfoo/Lesson02.hs view
@@ -2,6 +2,7 @@ module Lazyfoo.Lesson02 (main) where import Control.Concurrent (threadDelay)+import Control.Monad (void) import Foreign.C.Types import SDL.Vect import qualified SDL@@ -20,7 +21,7 @@ helloWorld <- getDataFileName "examples/lazyfoo/hello_world.bmp" >>= SDL.loadBMP - SDL.surfaceBlit helloWorld Nothing screenSurface Nothing+ void $ SDL.surfaceBlit helloWorld Nothing screenSurface Nothing SDL.updateWindowSurface window threadDelay 2000000
examples/lazyfoo/Lesson03.hs view
@@ -27,7 +27,7 @@ events <- SDL.pollEvents let quit = elem SDL.QuitEvent $ map SDL.eventPayload events - SDL.surfaceBlit xOut Nothing screenSurface Nothing+ void $ SDL.surfaceBlit xOut Nothing screenSurface Nothing SDL.updateWindowSurface window unless quit loop
examples/lazyfoo/Lesson04.hs view
@@ -56,7 +56,7 @@ _ -> mempty) events - SDL.surfaceBlit currentSurface Nothing screenSurface Nothing+ void $ SDL.surfaceBlit currentSurface Nothing screenSurface Nothing SDL.updateWindowSurface window unless quit (loop currentSurface)
examples/lazyfoo/Lesson12.hs view
@@ -83,9 +83,9 @@ SDL.ScancodeQ -> Sum (V3 32 0 0) SDL.ScancodeW -> Sum (V3 0 32 0) SDL.ScancodeE -> Sum (V3 0 0 32)- SDL.ScancodeA -> Sum (V3 (-32) 0 0)- SDL.ScancodeS -> Sum (V3 0 (-32) 0)- SDL.ScancodeD -> Sum (V3 0 0 (-32))+ SDL.ScancodeA -> Sum (V3 224 0 0)+ SDL.ScancodeS -> Sum (V3 0 224 0)+ SDL.ScancodeD -> Sum (V3 0 0 224) _ -> mempty | otherwise -> mempty _ -> mempty) $
examples/twinklebear/Lesson05.hs view
@@ -59,9 +59,12 @@ renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer spriteSheet <- getDataFileName "examples/twinklebear/spritesheet.bmp" >>= loadTexture renderer- let [spriteOne, spriteTwo, spriteThree, spriteFour] =- [ SDL.Rectangle (P (V2 (x * spriteWidth) (y * spriteHeight))) (V2 spriteWidth spriteHeight)- | x <- [0..1], y <- [0..1] ]++ let mkSprite x y = SDL.Rectangle (P (V2 (x * spriteWidth) (y * spriteHeight))) (V2 spriteWidth spriteHeight)+ spriteOne = mkSprite 0 0+ spriteTwo = mkSprite 0 1+ spriteThree = mkSprite 1 0+ spriteFour = mkSprite 1 1 let loop spriteRect = do events <- SDL.pollEvents
include/sdlhelper.h view
@@ -4,6 +4,8 @@ #include <stddef.h> #include "SDL.h" +int SDLHelper_GetEventBufferSize(void);+SDL_Event *SDLHelper_GetEventBuffer(void); void SDLHelper_JoystickGetDeviceGUID (int device_index, SDL_JoystickGUID *guid); void SDLHelper_JoystickGetGUID (SDL_Joystick *joystick, SDL_JoystickGUID *guid); void SDLHelper_JoystickGetGUIDFromString (const char *pchGUID, SDL_JoystickGUID *guid);
sdl2.cabal view
@@ -1,6 +1,6 @@ name: sdl2-version: 2.1.3.1-synopsis: Both high- and low-level bindings to the SDL library (version 2.0.2+).+version: 2.5.6.0+synopsis: Both high- and low-level bindings to the SDL library (version 2.0.6+). description: This package contains bindings to the SDL 2 library, in both high- and low-level forms:@@ -12,6 +12,8 @@ Haskell FFI calls. As such, this does not contain sum types nor error checking. Thus this namespace is suitable for building your own abstraction over SDL, but is not recommended for day-to-day programming.+ .+ Read "SDL" for a getting started guide. license: BSD3 license-file: LICENSE@@ -43,27 +45,41 @@ flag examples description: Build examples (except opengl-example) default: False+ manual: True flag opengl-example description: Build opengl-example default: False+ manual: True flag no-linear description: Do not depend on 'linear' library default: False manual: True +flag recent-ish+ description: Use features from a more recent libsdl2 release.+ default: True+ manual: False++flag pkgconfig+ description: Use pkgconfig to sort out SDL2 dependency+ default: True+ manual: True+ library- -- ghc-options: -Wall+ -- ghc-options: -Wall -Werror exposed-modules: SDL SDL.Audio SDL.Event+ SDL.Exception SDL.Filesystem SDL.Hint SDL.Init SDL.Input+ SDL.Input.GameController SDL.Input.Joystick SDL.Input.Keyboard SDL.Input.Keyboard.Codes@@ -74,7 +90,10 @@ SDL.Video SDL.Video.OpenGL SDL.Video.Renderer+ SDL.Video.Vulkan + SDL.Internal.Exception+ SDL.Internal.Numbered SDL.Internal.Types SDL.Internal.Vect @@ -95,8 +114,6 @@ other-modules: Data.Bitmask- SDL.Internal.Numbered- SDL.Exception hs-source-dirs: src/@@ -109,32 +126,60 @@ includes: SDL.h+ SDL_vulkan.h sdlhelper.h extra-libraries: SDL2 - pkgconfig-depends:- sdl2 >= 2.0.2+ if flag(recent-ish)+ cpp-options:+ -DRECENT_ISH+ if flag(pkgconfig)+ pkgconfig-depends:+ sdl2 >= 2.0.14+ else+ if flag(pkgconfig)+ pkgconfig-depends:+ sdl2 >= 2.0.9 build-depends: base >= 4.7 && < 5,- bytestring >= 0.10.4.0 && < 0.11,- exceptions >= 0.4 && < 0.9,- StateVar >= 1.1.0.0 && < 1.2,- text >= 1.1.0.0 && < 1.3,- transformers >= 0.2 && < 0.6,- vector >= 0.10.9.0 && < 0.13+ bytestring >= 0.10.4.0 && < 0.13,+ exceptions >= 0.4 && < 0.11,+ StateVar >= 1.1.0.0 && < 1.3,+ text >= 1.1.0.0 && < 2.2,+ transformers >= 0.2 && < 0.7,+ vector >= 0.10.9.0 && < 0.14 if flag(no-linear) cpp-options: -Dnolinear else build-depends:- linear >= 1.10.1.2 && < 1.21+ linear >= 1.10.1.2 && < 1.24 + if impl(ghc >= 8.6)+ default-extensions: NoStarIsType+ default-language: Haskell2010 + if os(windows)+ cpp-options: -D_SDL_main_h -DSDL_main_h_++test-suite sdl-space+ type: exitcode-stdio-1.0+ main-is: Space.hs+ hs-source-dirs: bench+ build-depends: base+ , weigh >= 0.0.8+ , linear+ , sdl2+ , deepseq+ , vector+ ghc-options: -Wall -rtsopts -O2+ default-language: Haskell2010+ executable lazyfoo-lesson-01 if flag(examples) build-depends: base, sdl2@@ -145,6 +190,7 @@ main-is: Lesson01.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson01+ other-modules: Paths_sdl2 executable lazyfoo-lesson-02 if flag(examples)@@ -156,6 +202,7 @@ main-is: Lesson02.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson02+ other-modules: Paths_sdl2 executable lazyfoo-lesson-03 if flag(examples)@@ -167,6 +214,7 @@ main-is: Lesson03.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson03+ other-modules: Paths_sdl2 executable lazyfoo-lesson-04 if flag(examples)@@ -178,6 +226,7 @@ main-is: Lesson04.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson04+ other-modules: Paths_sdl2 executable lazyfoo-lesson-05 if flag(examples)@@ -189,6 +238,7 @@ main-is: Lesson05.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson05+ other-modules: Paths_sdl2 executable lazyfoo-lesson-07 if flag(examples)@@ -200,6 +250,7 @@ main-is: Lesson07.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson07+ other-modules: Paths_sdl2 executable lazyfoo-lesson-08 if flag(examples)@@ -211,6 +262,7 @@ main-is: Lesson08.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson08+ other-modules: Paths_sdl2 executable lazyfoo-lesson-09 if flag(examples)@@ -222,6 +274,7 @@ main-is: Lesson09.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson09+ other-modules: Paths_sdl2 executable lazyfoo-lesson-10 if flag(examples)@@ -233,6 +286,7 @@ main-is: Lesson10.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson10+ other-modules: Paths_sdl2 executable lazyfoo-lesson-11 if flag(examples)@@ -244,6 +298,7 @@ main-is: Lesson11.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson11+ other-modules: Paths_sdl2 executable lazyfoo-lesson-12 if flag(examples)@@ -255,6 +310,7 @@ main-is: Lesson12.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson12+ other-modules: Paths_sdl2 executable lazyfoo-lesson-13 if flag(examples)@@ -266,6 +322,7 @@ main-is: Lesson13.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson13+ other-modules: Paths_sdl2 executable lazyfoo-lesson-14 if flag(examples)@@ -277,6 +334,7 @@ main-is: Lesson14.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson14+ other-modules: Paths_sdl2 executable lazyfoo-lesson-15 if flag(examples)@@ -288,6 +346,7 @@ main-is: Lesson15.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson15+ other-modules: Paths_sdl2 executable lazyfoo-lesson-17 if flag(examples)@@ -299,6 +358,7 @@ main-is: Lesson17.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson17+ other-modules: Paths_sdl2 executable lazyfoo-lesson-18 if flag(examples)@@ -310,6 +370,7 @@ main-is: Lesson18.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson18+ other-modules: Paths_sdl2 executable lazyfoo-lesson-19 if flag(examples)@@ -321,6 +382,7 @@ main-is: Lesson19.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson19+ other-modules: Paths_sdl2 executable lazyfoo-lesson-20 if flag(examples)@@ -335,6 +397,7 @@ main-is: Lesson20.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson20+ other-modules: Paths_sdl2 executable lazyfoo-lesson-43 if flag(examples)@@ -346,6 +409,7 @@ main-is: Lesson43.hs default-language: Haskell2010 ghc-options: -main-is Lazyfoo.Lesson43+ other-modules: Paths_sdl2 executable twinklebear-lesson-01 if flag(examples)@@ -357,6 +421,7 @@ main-is: Lesson01.hs default-language: Haskell2010 ghc-options: -main-is TwinkleBear.Lesson01+ other-modules: Paths_sdl2 executable twinklebear-lesson-02 if flag(examples)@@ -368,6 +433,7 @@ main-is: Lesson02.hs default-language: Haskell2010 ghc-options: -main-is TwinkleBear.Lesson02+ other-modules: Paths_sdl2 executable twinklebear-lesson-04 if flag(examples)@@ -379,6 +445,7 @@ main-is: Lesson04.hs default-language: Haskell2010 ghc-options: -main-is TwinkleBear.Lesson04+ other-modules: Paths_sdl2 executable twinklebear-lesson-04a if flag(examples)@@ -390,6 +457,7 @@ main-is: Lesson04a.hs default-language: Haskell2010 ghc-options: -main-is TwinkleBear.Lesson04a+ other-modules: Paths_sdl2 executable twinklebear-lesson-05 if flag(examples)@@ -401,6 +469,7 @@ main-is: Lesson05.hs default-language: Haskell2010 ghc-options: -main-is TwinkleBear.Lesson05+ other-modules: Paths_sdl2 executable audio-example if flag(examples)@@ -412,8 +481,44 @@ main-is: AudioExample.hs default-language: Haskell2010 ghc-options: -main-is AudioExample -threaded+ other-modules: Paths_sdl2 +executable eventwatch-example+ if flag(examples)+ build-depends: base, sdl2+ else+ buildable: False + hs-source-dirs: examples+ main-is: EventWatch.hs+ default-language: Haskell2010+ ghc-options: -main-is EventWatch+ other-modules: Paths_sdl2++executable userevent-example+ if flag(examples)+ build-depends: base, text, sdl2+ else+ buildable: False++ hs-source-dirs: examples+ main-is: UserEvents.hs+ default-language: Haskell2010+ ghc-options: -main-is UserEvents+ other-modules: Paths_sdl2++executable rendergeometry-example+ if flag(examples)+ build-depends: base, bytestring, vector, sdl2+ else+ buildable: False++ hs-source-dirs: examples+ main-is: RenderGeometry.hs+ default-language: Haskell2010+ ghc-options: -main-is RenderGeometry+ other-modules: Paths_sdl2+ executable opengl-example if flag(opengl-example) build-depends: base, OpenGL, bytestring, vector, sdl2@@ -424,3 +529,4 @@ main-is: OpenGLExample.hs default-language: Haskell2010 ghc-options: -main-is OpenGLExample+ other-modules: Paths_sdl2
src/SDL.hs view
@@ -26,20 +26,20 @@ , module SDL.Vect , module SDL.Video + -- * Error Handling+ , module SDL.Exception+ -- * Working with State Variables -- $stateVars , get, ($=), ($~) -- ** Strict modification , ($=!), ($~!)-- -- * Error Handling- , SDLException(..) ) where import Data.StateVar import SDL.Audio import SDL.Event-import SDL.Exception (SDLException(..))+import SDL.Exception import SDL.Filesystem import SDL.Hint import SDL.Init@@ -75,12 +75,18 @@ renderer <- 'createRenderer' window (-1) 'defaultRenderer' @ -Finally, we enter our main application loop:+Then, we enter our main application loop: @ appLoop renderer @ +Finally, once our appLoop has returned we destroy the 'Window' using 'destroyWindow':++@+ 'destroyWindow' window+@+ For the body of your application, we enter a loop. Inside this loop you should begin by collecting all events that have happened - these events will inform you about information such as key presses and mouse movement: @@ -99,7 +105,7 @@ 'keyboardEventKeyMotion' keyboardEvent == 'Pressed' && 'keysymKeycode' ('keyboardEventKeysym' keyboardEvent) == 'KeycodeQ' _ -> False- qPressed = not (null (filter eventIsQPress events))+ qPressed = any eventIsQPress events @ In our @appLoop@ we process events and then update the screen accordingly. Here we simply use the 'Renderer'@@ -134,6 +140,7 @@ window <- 'createWindow' "My SDL Application" 'defaultWindow' renderer <- 'createRenderer' window (-1) 'defaultRenderer' appLoop renderer+ destroyWindow window appLoop :: 'Renderer' -> IO () appLoop renderer = do
src/SDL/Audio.hs view
@@ -54,13 +54,7 @@ , getAudioDeviceNames -- * 'AudioSpec'- , AudioSpec- , audioSpecFreq- , audioSpecFormat- , audioSpecChannels- , audioSpecSilence- , audioSpecSize- , audioSpecCallback+ , AudioSpec(..) -- * Audio Drivers , getAudioDrivers@@ -89,7 +83,7 @@ import Foreign.Storable import GHC.Exts (Constraint) import GHC.Generics (Generic)-import SDL.Exception+import SDL.Internal.Exception import qualified Data.ByteString as BS import qualified Data.Text.Encoding as Text import qualified Data.Vector as V@@ -104,6 +98,12 @@ import Data.Traversable (Traversable) #endif +#if MIN_VERSION_base(4,12,0)+import Data.Kind (Type)+#else+# define Type *+#endif+ {- $audioDevice@@ -140,7 +140,7 @@ -- | Attempt to open the closest matching 'AudioDevice', as specified by the -- given 'OpenDeviceSpec'. ----- See @<https://wiki.libsdl.org/SDL_OpenAudioDevice SDL_OpenAudioDevice>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_OpenAudioDevice SDL_OpenAudioDevice>@ for C documentation. openAudioDevice :: MonadIO m => OpenDeviceSpec -> m (AudioDevice, AudioSpec) openAudioDevice OpenDeviceSpec{..} = liftIO $ maybeWith (BS.useAsCString . Text.encodeUtf8) openDeviceName $ \cDevName -> do@@ -175,9 +175,9 @@ return (audioDevice, spec) where- changes = foldl (.|.) 0 [ foldChangeable (const Raw.SDL_AUDIO_ALLOW_FREQUENCY_CHANGE) (const 0) openDeviceFreq- , foldChangeable (const Raw.SDL_AUDIO_ALLOW_FORMAT_CHANGE) (const 0) openDeviceFormat- , foldChangeable (const Raw.SDL_AUDIO_ALLOW_CHANNELS_CHANGE) (const 0) openDeviceChannels+ changes = foldl (.|.) 0 [ foldChangeable (const 0) (const Raw.SDL_AUDIO_ALLOW_FREQUENCY_CHANGE) openDeviceFreq+ , foldChangeable (const 0) (const Raw.SDL_AUDIO_ALLOW_FORMAT_CHANGE) openDeviceFormat+ , foldChangeable (const 0) (const Raw.SDL_AUDIO_ALLOW_CHANNELS_CHANGE) openDeviceChannels ] channelsToWord8 Mono = 1@@ -219,12 +219,12 @@ audioFormatStorable FloatingBEAudio = Dict audioFormatStorable FloatingNativeAudio = Dict -data Dict :: Constraint -> * where+data Dict :: Constraint -> Type where Dict :: c => Dict c -- | ----- See @<https://wiki.libsdl.org/SDL_CloseAudioDevice SDL_CloseAudioDevice>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_CloseAudioDevice SDL_CloseAudioDevice>@ for C documentation. closeAudioDevice :: MonadIO m => AudioDevice -> m () closeAudioDevice (AudioDevice d) = Raw.closeAudioDevice d
src/SDL/Event.hs view
@@ -17,8 +17,20 @@ , pumpEvents , waitEvent , waitEventTimeout+ -- * Registering user events+ , RegisteredEventType(..)+ , RegisteredEventData(..)+ , EventPushResult(..)+ , emptyRegisteredEvent+ , registerEvent+ -- * Watching events+ , EventWatchCallback+ , EventWatch+ , addEventWatch+ , delEventWatch -- * Event data , Event(..)+ , Timestamp , EventPayload(..) -- ** Window events , WindowShownEventData(..)@@ -54,17 +66,18 @@ , ControllerAxisEventData(..) , ControllerButtonEventData(..) , ControllerDeviceEventData(..)+ -- ** Audio events+ , AudioDeviceEventData(..) -- ** User events , UserEventData(..) -- ** Touch events , TouchFingerEventData(..)+ , TouchFingerMotionEventData(..) -- ** Gesture events , MultiGestureEventData(..) , DollarGestureEventData(..) -- ** Drag and drop events , DropEventData(..)- -- ** Clipboard events- , ClipboardUpdateEventData(..) -- ** Unknown events , UnknownEventData(..) -- * Auxiliary event data@@ -77,89 +90,96 @@ import Data.Maybe (catMaybes) import Data.Text (Text) import Data.Typeable-import Foreign+import Foreign hiding (throwIfNeg_) import Foreign.C import GHC.Generics (Generic) import SDL.Vect+import SDL.Input.Joystick+import SDL.Input.GameController import SDL.Input.Keyboard import SDL.Input.Mouse+import SDL.Internal.Exception import SDL.Internal.Numbered import SDL.Internal.Types (Window(Window)) import qualified Data.ByteString.Char8 as BSC8 import qualified Data.Text.Encoding as Text-import qualified SDL.Exception as SDLEx import qualified SDL.Raw as Raw #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif --- | A single SDL event. This event occured at 'eventTimestamp' and carries data under 'eventPayload'.+-- | A single SDL event. This event occurred at 'eventTimestamp' and carries data under 'eventPayload'. data Event = Event- { eventTimestamp :: Word32- -- ^ The time the event occured.+ { eventTimestamp :: Timestamp+ -- ^ The time the event occurred. , eventPayload :: EventPayload -- ^ Data pertaining to this event. } deriving (Eq, Ord, Generic, Show, Typeable) +type Timestamp = Word32+ -- | An enumeration of all possible SDL event types. This data type pairs up event types with -- their payload, where possible. data EventPayload- = WindowShownEvent WindowShownEventData- | WindowHiddenEvent WindowHiddenEventData- | WindowExposedEvent WindowExposedEventData- | WindowMovedEvent WindowMovedEventData- | WindowResizedEvent WindowResizedEventData- | WindowSizeChangedEvent WindowSizeChangedEventData- | WindowMinimizedEvent WindowMinimizedEventData- | WindowMaximizedEvent WindowMaximizedEventData- | WindowRestoredEvent WindowRestoredEventData- | WindowGainedMouseFocusEvent WindowGainedMouseFocusEventData- | WindowLostMouseFocusEvent WindowLostMouseFocusEventData- | WindowGainedKeyboardFocusEvent WindowGainedKeyboardFocusEventData- | WindowLostKeyboardFocusEvent WindowLostKeyboardFocusEventData- | WindowClosedEvent WindowClosedEventData- | KeyboardEvent KeyboardEventData- | TextEditingEvent TextEditingEventData- | TextInputEvent TextInputEventData- | MouseMotionEvent MouseMotionEventData- | MouseButtonEvent MouseButtonEventData- | MouseWheelEvent MouseWheelEventData- | JoyAxisEvent JoyAxisEventData- | JoyBallEvent JoyBallEventData- | JoyHatEvent JoyHatEventData- | JoyButtonEvent JoyButtonEventData- | JoyDeviceEvent JoyDeviceEventData- | ControllerAxisEvent ControllerAxisEventData- | ControllerButtonEvent ControllerButtonEventData- | ControllerDeviceEvent ControllerDeviceEventData+ = WindowShownEvent !WindowShownEventData+ | WindowHiddenEvent !WindowHiddenEventData+ | WindowExposedEvent !WindowExposedEventData+ | WindowMovedEvent !WindowMovedEventData+ | WindowResizedEvent !WindowResizedEventData+ | WindowSizeChangedEvent !WindowSizeChangedEventData+ | WindowMinimizedEvent !WindowMinimizedEventData+ | WindowMaximizedEvent !WindowMaximizedEventData+ | WindowRestoredEvent !WindowRestoredEventData+ | WindowGainedMouseFocusEvent !WindowGainedMouseFocusEventData+ | WindowLostMouseFocusEvent !WindowLostMouseFocusEventData+ | WindowGainedKeyboardFocusEvent !WindowGainedKeyboardFocusEventData+ | WindowLostKeyboardFocusEvent !WindowLostKeyboardFocusEventData+ | WindowClosedEvent !WindowClosedEventData+ | KeyboardEvent !KeyboardEventData+ | TextEditingEvent !TextEditingEventData+ | TextInputEvent !TextInputEventData+ | KeymapChangedEvent+ | MouseMotionEvent !MouseMotionEventData+ | MouseButtonEvent !MouseButtonEventData+ | MouseWheelEvent !MouseWheelEventData+ | JoyAxisEvent !JoyAxisEventData+ | JoyBallEvent !JoyBallEventData+ | JoyHatEvent !JoyHatEventData+ | JoyButtonEvent !JoyButtonEventData+ | JoyDeviceEvent !JoyDeviceEventData+ | ControllerAxisEvent !ControllerAxisEventData+ | ControllerButtonEvent !ControllerButtonEventData+ | ControllerDeviceEvent !ControllerDeviceEventData+ | AudioDeviceEvent !AudioDeviceEventData | QuitEvent- | UserEvent UserEventData- | SysWMEvent SysWMEventData- | TouchFingerEvent TouchFingerEventData- | MultiGestureEvent MultiGestureEventData- | DollarGestureEvent DollarGestureEventData- | DropEvent DropEventData- | ClipboardUpdateEvent ClipboardUpdateEventData- | UnknownEvent UnknownEventData+ | UserEvent !UserEventData+ | SysWMEvent !SysWMEventData+ | TouchFingerEvent !TouchFingerEventData+ | TouchFingerMotionEvent !TouchFingerMotionEventData+ | MultiGestureEvent !MultiGestureEventData+ | DollarGestureEvent !DollarGestureEventData+ | DropEvent !DropEventData+ | ClipboardUpdateEvent+ | UnknownEvent !UnknownEventData deriving (Eq, Ord, Generic, Show, Typeable) -- | A window has been shown.-data WindowShownEventData =+newtype WindowShownEventData = WindowShownEventData {windowShownEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A window has been hidden.-data WindowHiddenEventData =+newtype WindowHiddenEventData = WindowHiddenEventData {windowHiddenEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A part of a window has been exposed - where exposure means to become visible (for example, an overlapping window no longer overlaps with the window).-data WindowExposedEventData =+newtype WindowExposedEventData = WindowExposedEventData {windowExposedEventWindow :: Window -- ^ The associated 'Window'. }@@ -167,80 +187,82 @@ -- | A 'Window' has been moved. data WindowMovedEventData =- WindowMovedEventData {windowMovedEventWindow :: Window+ WindowMovedEventData {windowMovedEventWindow :: !Window -- ^ The associated 'Window'.- ,windowMovedEventPosition :: Point V2 Int32+ ,windowMovedEventPosition :: !(Point V2 Int32) -- ^ The new position of the 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Window has been resized. This is event is always preceded by 'WindowSizeChangedEvent'. data WindowResizedEventData =- WindowResizedEventData {windowResizedEventWindow :: Window+ WindowResizedEventData {windowResizedEventWindow :: !Window -- ^ The associated 'Window'.- ,windowResizedEventSize :: V2 Int32+ ,windowResizedEventSize :: !(V2 Int32) -- ^ The new size of the 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window size has changed, either as a result of an API call or through the system or user changing the window size; this event is followed by 'WindowResizedEvent' if the size was changed by an external event, i.e. the user or the window manager. data WindowSizeChangedEventData =- WindowSizeChangedEventData {windowSizeChangedEventWindow :: Window+ WindowSizeChangedEventData {windowSizeChangedEventWindow :: !Window -- ^ The associated 'Window'.+ ,windowSizeChangedEventSize :: !(V2 Int32)+ -- ^ The new size of the 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has been minimized.-data WindowMinimizedEventData =+newtype WindowMinimizedEventData = WindowMinimizedEventData {windowMinimizedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has been maximized.-data WindowMaximizedEventData =+newtype WindowMaximizedEventData = WindowMaximizedEventData {windowMaximizedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has been restored to normal size and position.-data WindowRestoredEventData =+newtype WindowRestoredEventData = WindowRestoredEventData {windowRestoredEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has gained mouse focus.-data WindowGainedMouseFocusEventData =+newtype WindowGainedMouseFocusEventData = WindowGainedMouseFocusEventData {windowGainedMouseFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has lost mouse focus.-data WindowLostMouseFocusEventData =+newtype WindowLostMouseFocusEventData = WindowLostMouseFocusEventData {windowLostMouseFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has gained keyboard focus.-data WindowGainedKeyboardFocusEventData =+newtype WindowGainedKeyboardFocusEventData = WindowGainedKeyboardFocusEventData {windowGainedKeyboardFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has lost keyboard focus.-data WindowLostKeyboardFocusEventData =+newtype WindowLostKeyboardFocusEventData = WindowLostKeyboardFocusEventData {windowLostKeyboardFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window manager requests that the window be closed.-data WindowClosedEventData =+newtype WindowClosedEventData = WindowClosedEventData {windowClosedEventWindow :: Window -- ^ The associated 'Window'. }@@ -248,239 +270,267 @@ -- | A keyboard key has been pressed or released. data KeyboardEventData =- KeyboardEventData {keyboardEventWindow :: Window- -- ^ The associated 'Window'.- ,keyboardEventKeyMotion :: InputMotion+ KeyboardEventData {keyboardEventWindow :: !(Maybe Window)+ -- ^ The 'Window' with keyboard focus, if any.+ ,keyboardEventKeyMotion :: !InputMotion -- ^ Whether the key was pressed or released.- ,keyboardEventRepeat :: Bool+ ,keyboardEventRepeat :: !Bool -- ^ 'True' if this is a repeating key press from the user holding the key down.- ,keyboardEventKeysym :: Keysym+ ,keyboardEventKeysym :: !Keysym -- ^ A description of the key that this event pertains to. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Keyboard text editing event information. data TextEditingEventData =- TextEditingEventData {textEditingEventWindow :: Window- -- ^ The associated 'Window'.- ,textEditingEventText :: Text+ TextEditingEventData {textEditingEventWindow :: !(Maybe Window)+ -- ^ The 'Window' with keyboard focus, if any.+ ,textEditingEventText :: !Text -- ^ The editing text.- ,textEditingEventStart :: Int32+ ,textEditingEventStart :: !Int32 -- ^ The location to begin editing from.- ,textEditingEventLength :: Int32+ ,textEditingEventLength :: !Int32 -- ^ The number of characters to edit from the start point. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Keyboard text input event information. data TextInputEventData =- TextInputEventData {textInputEventWindow :: Window- -- ^ The associated 'Window'.- ,textInputEventText :: Text+ TextInputEventData {textInputEventWindow :: !(Maybe Window)+ -- ^ The 'Window' with keyboard focus, if any.+ ,textInputEventText :: !Text -- ^ The input text. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A mouse or pointer device was moved. data MouseMotionEventData =- MouseMotionEventData {mouseMotionEventWindow :: Window- -- ^ The associated 'Window'.- ,mouseMotionEventWhich :: MouseDevice+ MouseMotionEventData {mouseMotionEventWindow :: !(Maybe Window)+ -- ^ The 'Window' with mouse focus, if any.+ ,mouseMotionEventWhich :: !MouseDevice -- ^ The 'MouseDevice' that was moved.- ,mouseMotionEventState :: [MouseButton]+ ,mouseMotionEventState :: ![MouseButton] -- ^ A collection of 'MouseButton's that are currently held down.- ,mouseMotionEventPos :: Point V2 Int32+ ,mouseMotionEventPos :: !(Point V2 Int32) -- ^ The new position of the mouse.- ,mouseMotionEventRelMotion :: V2 Int32+ ,mouseMotionEventRelMotion :: !(V2 Int32) -- ^ The relative mouse motion of the mouse. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A mouse or pointer device button was pressed or released. data MouseButtonEventData =- MouseButtonEventData {mouseButtonEventWindow :: Window- -- ^ The associated 'Window'.- ,mouseButtonEventMotion :: InputMotion+ MouseButtonEventData {mouseButtonEventWindow :: !(Maybe Window)+ -- ^ The 'Window' with mouse focus, if any.+ ,mouseButtonEventMotion :: !InputMotion -- ^ Whether the button was pressed or released.- ,mouseButtonEventWhich :: MouseDevice+ ,mouseButtonEventWhich :: !MouseDevice -- ^ The 'MouseDevice' whose button was pressed or released.- ,mouseButtonEventButton :: MouseButton+ ,mouseButtonEventButton :: !MouseButton -- ^ The button that was pressed or released.- ,mouseButtonEventClicks :: Word8+ ,mouseButtonEventClicks :: !Word8 -- ^ The amount of clicks. 1 for a single-click, 2 for a double-click, etc.- ,mouseButtonEventPos :: Point V2 Int32+ ,mouseButtonEventPos :: !(Point V2 Int32) -- ^ The coordinates of the mouse click. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Mouse wheel event information. data MouseWheelEventData =- MouseWheelEventData {mouseWheelEventWindow :: Window- -- ^ The associated 'Window'.- ,mouseWheelEventWhich :: MouseDevice+ MouseWheelEventData {mouseWheelEventWindow :: !(Maybe Window)+ -- ^ The 'Window' with mouse focus, if any.+ ,mouseWheelEventWhich :: !MouseDevice -- ^ The 'MouseDevice' whose wheel was scrolled.- ,mouseWheelEventPos :: V2 Int32+ ,mouseWheelEventPos :: !(V2 Int32) -- ^ The amount scrolled.+ ,mouseWheelEventDirection :: !MouseScrollDirection+ -- ^ The scroll direction mode. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Joystick axis motion event information data JoyAxisEventData =- JoyAxisEventData {joyAxisEventWhich :: Raw.JoystickID+ JoyAxisEventData {joyAxisEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event.- ,joyAxisEventAxis :: Word8+ ,joyAxisEventAxis :: !Word8 -- ^ The index of the axis that changed.- ,joyAxisEventValue :: Int16+ ,joyAxisEventValue :: !Int16 -- ^ The current position of the axis, ranging between -32768 and 32767. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Joystick trackball motion event information. data JoyBallEventData =- JoyBallEventData {joyBallEventWhich :: Raw.JoystickID+ JoyBallEventData {joyBallEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event.- ,joyBallEventBall :: Word8+ ,joyBallEventBall :: !Word8 -- ^ The index of the trackball that changed.- ,joyBallEventRelMotion :: V2 Int16+ ,joyBallEventRelMotion :: !(V2 Int16) -- ^ The relative motion of the trackball. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Joystick hat position change event information data JoyHatEventData =- JoyHatEventData {joyHatEventWhich :: Raw.JoystickID+ JoyHatEventData {joyHatEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event.- ,joyHatEventHat :: Word8+ ,joyHatEventHat :: !Word8 -- ^ The index of the hat that changed.- ,joyHatEventValue :: Word8+ ,joyHatEventValue :: !JoyHatPosition -- ^ The new position of the hat. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Joystick button event information. data JoyButtonEventData =- JoyButtonEventData {joyButtonEventWhich :: Raw.JoystickID+ JoyButtonEventData {joyButtonEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event.- ,joyButtonEventButton :: Word8+ ,joyButtonEventButton :: !Word8 -- ^ The index of the button that changed.- ,joyButtonEventState :: Word8+ ,joyButtonEventState :: !JoyButtonState -- ^ The state of the button. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Joystick device event information. data JoyDeviceEventData =- JoyDeviceEventData {joyDeviceEventWhich :: Int32+ JoyDeviceEventData {joyDeviceEventConnection :: !JoyDeviceConnection+ -- ^ Was the device added or removed?+ ,joyDeviceEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Game controller axis motion event information. data ControllerAxisEventData =- ControllerAxisEventData {controllerAxisEventWhich :: Raw.JoystickID+ ControllerAxisEventData {controllerAxisEventWhich :: !Raw.JoystickID -- ^ The joystick instance ID that reported the event.- ,controllerAxisEventAxis :: Word8+ ,controllerAxisEventAxis :: !ControllerAxis -- ^ The index of the axis.- ,controllerAxisEventValue :: Int16+ ,controllerAxisEventValue :: !Int16 -- ^ The axis value ranging between -32768 and 32767. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Game controller button event information data ControllerButtonEventData =- ControllerButtonEventData {controllerButtonEventWhich :: Raw.JoystickID+ ControllerButtonEventData {controllerButtonEventWhich :: !Raw.JoystickID -- ^ The joystick instance ID that reported the event.- ,controllerButtonEventButton :: Word8+ ,controllerButtonEventButton :: !ControllerButton -- ^ The controller button.- ,controllerButtonEventState :: Word8+ ,controllerButtonEventState :: !ControllerButtonState -- ^ The state of the button. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Controller device event information data ControllerDeviceEventData =- ControllerDeviceEventData {controllerDeviceEventWhich :: Int32- -- ^ The joystick instance ID that reported the event.+ ControllerDeviceEventData {controllerDeviceEventConnection :: !ControllerDeviceConnection+ -- ^ Was the device added, removed, or remapped?+ ,controllerDeviceEventWhich :: !Raw.JoystickID+ -- ^ The joystick device index for the ADDED event, instance id for the REMOVED or REMAPPED event } deriving (Eq,Ord,Generic,Show,Typeable) +data AudioDeviceEventData =+ AudioDeviceEventData {audioDeviceEventIsAddition :: !Bool+ -- ^ If the audio device is an addition, or a removal.+ ,audioDeviceEventWhich :: !Word32+ -- ^ The audio device ID that reported the event.+ ,audioDeviceEventIsCapture :: !Bool+ -- ^ If the audio device is a capture device.+ }+ deriving (Eq,Ord,Generic,Show,Typeable)+ -- | Event data for application-defined events. data UserEventData =- UserEventData {userEventWindow :: Window+ UserEventData {userEventType :: !Word32+ -- ^ User defined event type.+ ,userEventWindow :: !(Maybe Window) -- ^ The associated 'Window'.- ,userEventCode :: Int32+ ,userEventCode :: !Int32 -- ^ User defined event code.- ,userEventData1 :: Ptr ()+ ,userEventData1 :: !(Ptr ()) -- ^ User defined data pointer.- ,userEventData2 :: Ptr ()+ ,userEventData2 :: !(Ptr ()) -- ^ User defined data pointer. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A video driver dependent system event-data SysWMEventData =+newtype SysWMEventData = SysWMEventData {sysWMEventMsg :: Raw.SysWMmsg} deriving (Eq,Ord,Generic,Show,Typeable) -- | Finger touch event information. data TouchFingerEventData =- TouchFingerEventData {touchFingerEventTouchID :: Raw.TouchID+ TouchFingerEventData {touchFingerEventTouchID :: !Raw.TouchID -- ^ The touch device index.- ,touchFingerEventFingerID :: Raw.FingerID+ ,touchFingerEventFingerID :: !Raw.FingerID -- ^ The finger index.- ,touchFingerEventPos :: Point V2 CFloat+ ,touchFingerEventMotion :: !InputMotion+ -- ^ Whether the finger was pressed or released.+ ,touchFingerEventPos :: !(Point V2 CFloat) -- ^ The location of the touch event, normalized between 0 and 1.- ,touchFingerEventRelMotion :: V2 CFloat- -- ^ The distance moved, normalized between -1 and 1.- ,touchFingerEventPressure :: CFloat+ ,touchFingerEventPressure :: !CFloat -- ^ The quantity of the pressure applied, normalized between 0 and 1. } deriving (Eq,Ord,Generic,Show,Typeable) +-- | Finger motion event information.+data TouchFingerMotionEventData =+ TouchFingerMotionEventData {touchFingerMotionEventTouchID :: !Raw.TouchID+ -- ^ The touch device index.+ ,touchFingerMotionEventFingerID :: !Raw.FingerID+ -- ^ The finger index.+ ,touchFingerMotionEventPos :: !(Point V2 CFloat)+ -- ^ The location of the touch event, normalized between 0 and 1.+ ,touchFingerMotionEventRelMotion :: !(V2 CFloat)+ -- ^ The distance moved, normalized between -1 and 1.+ ,touchFingerMotionEventPressure :: !CFloat+ -- ^ The quantity of the pressure applied, normalized between 0 and 1.+ }+ deriving (Eq,Ord,Generic,Show,Typeable)+ -- | Multiple finger gesture event information data MultiGestureEventData =- MultiGestureEventData {multiGestureEventTouchID :: Raw.TouchID+ MultiGestureEventData {multiGestureEventTouchID :: !Raw.TouchID -- ^ The touch device index.- ,multiGestureEventDTheta :: CFloat+ ,multiGestureEventDTheta :: !CFloat -- ^ The amount that the fingers rotated during this motion.- ,multiGestureEventDDist :: CFloat+ ,multiGestureEventDDist :: !CFloat -- ^ The amount that the fingers pinched during this motion.- ,multiGestureEventPos :: Point V2 CFloat+ ,multiGestureEventPos :: !(Point V2 CFloat) -- ^ The normalized center of the gesture.- ,multiGestureEventNumFingers :: Word16+ ,multiGestureEventNumFingers :: !Word16 -- ^ The number of fingers used in this gesture. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Complex gesture event information. data DollarGestureEventData =- DollarGestureEventData {dollarGestureEventTouchID :: Raw.TouchID+ DollarGestureEventData {dollarGestureEventTouchID :: !Raw.TouchID -- ^ The touch device index.- ,dollarGestureEventGestureID :: Raw.GestureID+ ,dollarGestureEventGestureID :: !Raw.GestureID -- ^ The unique id of the closest gesture to the performed stroke.- ,dollarGestureEventNumFingers :: Word32+ ,dollarGestureEventNumFingers :: !Word32 -- ^ The number of fingers used to draw the stroke.- ,dollarGestureEventError :: CFloat+ ,dollarGestureEventError :: !CFloat -- ^ The difference between the gesture template and the actual performed gesture (lower errors correspond to closer matches).- ,dollarGestureEventPos :: Point V2 CFloat+ ,dollarGestureEventPos :: !(Point V2 CFloat) -- ^ The normalized center of the gesture. } deriving (Eq,Ord,Generic,Show,Typeable) -- | An event used to request a file open by the system-data DropEventData =+newtype DropEventData = DropEventData {dropEventFile :: CString -- ^ The file name. } deriving (Eq,Ord,Generic,Show,Typeable) --- | The clipboard changed.-data ClipboardUpdateEventData =- ClipboardUpdateEventData- deriving (Eq,Ord,Generic,Show,Typeable)- -- | SDL reported an unknown event type.-data UnknownEventData =+newtype UnknownEventData = UnknownEventData {unknownEventType :: Word32 -- ^ The unknown event code. }@@ -501,76 +551,78 @@ convertRaw :: Raw.Event -> IO Event convertRaw (Raw.WindowEvent t ts a b c d) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- fmap Window (Raw.getWindowFromID a) return (Event ts (case b of Raw.SDL_WINDOWEVENT_SHOWN ->- WindowShownEvent (WindowShownEventData w')+ WindowShownEvent (WindowShownEventData w) Raw.SDL_WINDOWEVENT_HIDDEN ->- WindowHiddenEvent (WindowHiddenEventData w')+ WindowHiddenEvent (WindowHiddenEventData w) Raw.SDL_WINDOWEVENT_EXPOSED ->- WindowExposedEvent (WindowExposedEventData w')+ WindowExposedEvent (WindowExposedEventData w) Raw.SDL_WINDOWEVENT_MOVED -> WindowMovedEvent- (WindowMovedEventData w'+ (WindowMovedEventData w (P (V2 c d))) Raw.SDL_WINDOWEVENT_RESIZED -> WindowResizedEvent- (WindowResizedEventData w'+ (WindowResizedEventData w (V2 c d)) Raw.SDL_WINDOWEVENT_SIZE_CHANGED ->- WindowSizeChangedEvent (WindowSizeChangedEventData w')+ WindowSizeChangedEvent (WindowSizeChangedEventData w (V2 c d)) Raw.SDL_WINDOWEVENT_MINIMIZED ->- WindowMinimizedEvent (WindowMinimizedEventData w')+ WindowMinimizedEvent (WindowMinimizedEventData w) Raw.SDL_WINDOWEVENT_MAXIMIZED ->- WindowMaximizedEvent (WindowMaximizedEventData w')+ WindowMaximizedEvent (WindowMaximizedEventData w) Raw.SDL_WINDOWEVENT_RESTORED ->- WindowRestoredEvent (WindowRestoredEventData w')+ WindowRestoredEvent (WindowRestoredEventData w) Raw.SDL_WINDOWEVENT_ENTER ->- WindowGainedMouseFocusEvent (WindowGainedMouseFocusEventData w')+ WindowGainedMouseFocusEvent (WindowGainedMouseFocusEventData w) Raw.SDL_WINDOWEVENT_LEAVE ->- WindowLostMouseFocusEvent (WindowLostMouseFocusEventData w')+ WindowLostMouseFocusEvent (WindowLostMouseFocusEventData w) Raw.SDL_WINDOWEVENT_FOCUS_GAINED ->- WindowGainedKeyboardFocusEvent (WindowGainedKeyboardFocusEventData w')+ WindowGainedKeyboardFocusEvent (WindowGainedKeyboardFocusEventData w) Raw.SDL_WINDOWEVENT_FOCUS_LOST ->- WindowLostKeyboardFocusEvent (WindowLostKeyboardFocusEventData w')+ WindowLostKeyboardFocusEvent (WindowLostKeyboardFocusEventData w) Raw.SDL_WINDOWEVENT_CLOSE ->- WindowClosedEvent (WindowClosedEventData w')+ WindowClosedEvent (WindowClosedEventData w) _ -> UnknownEvent (UnknownEventData t))) convertRaw (Raw.KeyboardEvent Raw.SDL_KEYDOWN ts a _ c d) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- getWindowFromID a return (Event ts (KeyboardEvent- (KeyboardEventData w'+ (KeyboardEventData w Pressed (c /= 0) (fromRawKeysym d)))) convertRaw (Raw.KeyboardEvent Raw.SDL_KEYUP ts a _ c d) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- getWindowFromID a return (Event ts (KeyboardEvent- (KeyboardEventData w'+ (KeyboardEventData w Released (c /= 0) (fromRawKeysym d))))-convertRaw (Raw.KeyboardEvent _ _ _ _ _ _) = error "convertRaw: Unknown keyboard motion"+convertRaw Raw.KeyboardEvent{} = error "convertRaw: Unknown keyboard motion" convertRaw (Raw.TextEditingEvent _ ts a b c d) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- getWindowFromID a return (Event ts (TextEditingEvent- (TextEditingEventData w'+ (TextEditingEventData w (ccharStringToText b) c d))) convertRaw (Raw.TextInputEvent _ ts a b) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- getWindowFromID a return (Event ts (TextInputEvent- (TextInputEventData w'+ (TextInputEventData w (ccharStringToText b))))+convertRaw (Raw.KeymapChangedEvent _ ts) =+ return (Event ts KeymapChangedEvent) convertRaw (Raw.MouseMotionEvent _ ts a b c d e f g) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- getWindowFromID a let buttons = catMaybes [(Raw.SDL_BUTTON_LMASK `test` c) ButtonLeft ,(Raw.SDL_BUTTON_RMASK `test` c) ButtonRight@@ -579,7 +631,7 @@ ,(Raw.SDL_BUTTON_X2MASK `test` c) ButtonX2] return (Event ts (MouseMotionEvent- (MouseMotionEventData w'+ (MouseMotionEventData w (fromNumber b) buttons (P (V2 d e))@@ -589,33 +641,27 @@ then Just else const Nothing convertRaw (Raw.MouseButtonEvent t ts a b c _ e f g) =- do w' <- fmap Window (Raw.getWindowFromID a)+ do w <- getWindowFromID a let motion | t == Raw.SDL_MOUSEBUTTONUP = Released | t == Raw.SDL_MOUSEBUTTONDOWN = Pressed | otherwise = error "convertRaw: Unexpected mouse button motion"- button- | c == Raw.SDL_BUTTON_LEFT = ButtonLeft- | c == Raw.SDL_BUTTON_MIDDLE = ButtonMiddle- | c == Raw.SDL_BUTTON_RIGHT = ButtonRight- | c == Raw.SDL_BUTTON_X1 = ButtonX1- | c == Raw.SDL_BUTTON_X2 = ButtonX2- | otherwise = ButtonExtra $ fromIntegral c return (Event ts (MouseButtonEvent- (MouseButtonEventData w'+ (MouseButtonEventData w motion (fromNumber b)- button+ (fromNumber c) e (P (V2 f g)))))-convertRaw (Raw.MouseWheelEvent _ ts a b c d) =- do w' <- fmap Window (Raw.getWindowFromID a)+convertRaw (Raw.MouseWheelEvent _ ts a b c d e) =+ do w <- getWindowFromID a return (Event ts (MouseWheelEvent- (MouseWheelEventData w'+ (MouseWheelEventData w (fromNumber b)- (V2 c d))))+ (V2 c d)+ (fromNumber e)))) convertRaw (Raw.JoyAxisEvent _ ts a b c) = return (Event ts (JoyAxisEvent (JoyAxisEventData a b c))) convertRaw (Raw.JoyBallEvent _ ts a b c d) =@@ -625,32 +671,60 @@ b (V2 c d)))) convertRaw (Raw.JoyHatEvent _ ts a b c) =- return (Event ts (JoyHatEvent (JoyHatEventData a b c)))+ return (Event ts+ (JoyHatEvent+ (JoyHatEventData a+ b+ (fromNumber c)))) convertRaw (Raw.JoyButtonEvent _ ts a b c) =- return (Event ts (JoyButtonEvent (JoyButtonEventData a b c)))-convertRaw (Raw.JoyDeviceEvent _ ts a) =- return (Event ts (JoyDeviceEvent (JoyDeviceEventData a)))+ return (Event ts (JoyButtonEvent (JoyButtonEventData a b (fromNumber c))))+convertRaw (Raw.JoyDeviceEvent t ts a) =+ return (Event ts (JoyDeviceEvent (JoyDeviceEventData (fromNumber t) a))) convertRaw (Raw.ControllerAxisEvent _ ts a b c) =- return (Event ts (ControllerAxisEvent (ControllerAxisEventData a b c)))-convertRaw (Raw.ControllerButtonEvent _ ts a b c) =- return (Event ts (ControllerButtonEvent (ControllerButtonEventData a b c)))-convertRaw (Raw.ControllerDeviceEvent _ ts a) =- return (Event ts (ControllerDeviceEvent (ControllerDeviceEventData a)))+ return (Event ts+ (ControllerAxisEvent+ (ControllerAxisEventData a+ (fromNumber $ fromIntegral b)+ c)))+convertRaw (Raw.ControllerButtonEvent t ts a b _) =+ return (Event ts+ (ControllerButtonEvent+ (ControllerButtonEventData a+ (fromNumber $ fromIntegral b)+ (fromNumber t))))+convertRaw (Raw.ControllerDeviceEvent t ts a) =+ return (Event ts (ControllerDeviceEvent (ControllerDeviceEventData (fromNumber t) a)))+convertRaw (Raw.AudioDeviceEvent Raw.SDL_AUDIODEVICEADDED ts a b) =+ return (Event ts (AudioDeviceEvent (AudioDeviceEventData True a (b /= 0))))+convertRaw (Raw.AudioDeviceEvent Raw.SDL_AUDIODEVICEREMOVED ts a b) =+ return (Event ts (AudioDeviceEvent (AudioDeviceEventData False a (b /= 0))))+convertRaw Raw.AudioDeviceEvent{} =+ error "convertRaw: Unknown audio device motion" convertRaw (Raw.QuitEvent _ ts) = return (Event ts QuitEvent)-convertRaw (Raw.UserEvent _ ts a b c d) =- do w' <- fmap Window (Raw.getWindowFromID a)- return (Event ts (UserEvent (UserEventData w' b c d)))+convertRaw (Raw.UserEvent t ts a b c d) =+ do w <- getWindowFromID a+ return (Event ts (UserEvent (UserEventData t w b c d))) convertRaw (Raw.SysWMEvent _ ts a) = return (Event ts (SysWMEvent (SysWMEventData a)))-convertRaw (Raw.TouchFingerEvent _ ts a b c d e f g) =- return (Event ts- (TouchFingerEvent- (TouchFingerEventData a- b- (P (V2 c d))- (V2 e f)- g)))+convertRaw (Raw.TouchFingerEvent t ts a b c d e f g) =+ do let touchFingerEvent motion = TouchFingerEvent+ (TouchFingerEventData a+ b+ motion+ (P (V2 c d))+ g)+ let touchFingerMotionEvent = TouchFingerMotionEvent+ (TouchFingerMotionEventData a+ b+ (P (V2 c d))+ (V2 e f)+ g)+ case t of+ Raw.SDL_FINGERDOWN -> return (Event ts (touchFingerEvent Pressed))+ Raw.SDL_FINGERUP -> return (Event ts (touchFingerEvent Released))+ Raw.SDL_FINGERMOTION -> return (Event ts touchFingerMotionEvent)+ _ -> error "convertRaw: Unexpected touch finger event" convertRaw (Raw.MultiGestureEvent _ ts a b c d e f) = return (Event ts (MultiGestureEvent@@ -670,25 +744,45 @@ convertRaw (Raw.DropEvent _ ts a) = return (Event ts (DropEvent (DropEventData a))) convertRaw (Raw.ClipboardUpdateEvent _ ts) =- return (Event ts (ClipboardUpdateEvent ClipboardUpdateEventData))+ return (Event ts ClipboardUpdateEvent) convertRaw (Raw.UnknownEvent t ts) = return (Event ts (UnknownEvent (UnknownEventData t))) --- | Poll for currently pending events. You can only call this function in the thread that set the video mode.+-- | Poll for currently pending events. You can only call this function in the+-- OS thread that set the video mode. pollEvent :: MonadIO m => m (Maybe Event)-pollEvent = liftIO $ alloca $ \e -> do- n <- Raw.pollEvent e- if n == 0- then return Nothing- else fmap Just (peek e >>= convertRaw)+pollEvent =+ liftIO $ do+ n <- Raw.pollEvent nullPtr+ -- We use NULL first to check if there's an event.+ if n == 0+ then return Nothing+ else alloca $ \e -> do+ n' <- Raw.pollEvent e+ -- Checking 0 again doesn't hurt and it's good to be safe.+ if n' == 0+ then return Nothing+ else fmap Just (peek e >>= convertRaw) -- | Clear the event queue by polling for all pending events.-pollEvents :: (Functor m, MonadIO m) => m [Event]-pollEvents =- do e <- pollEvent- case e of- Nothing -> return []- Just e' -> (e' :) <$> pollEvents+--+-- Like 'pollEvent' this function should only be called in the OS thread which+-- set the video mode.+pollEvents :: MonadIO m => m [Event]+pollEvents = liftIO $ do+ Raw.pumpEvents+ peepAllEvents >>= mapM convertRaw where+ peepAllEvents = do+ numPeeped <- Raw.peepEvents+ Raw.eventBuffer+ Raw.eventBufferSize+ Raw.SDL_GETEVENT+ Raw.SDL_FIRSTEVENT+ Raw.SDL_LASTEVENT+ peeped <- peekArray (fromIntegral numPeeped) Raw.eventBuffer+ if numPeeped == Raw.eventBufferSize -- are there more events to peep?+ then (peeped ++) <$> peepAllEvents+ else return peeped -- | Run a monadic computation, accumulating over all known 'Event's. --@@ -703,7 +797,7 @@ -- | Wait indefinitely for the next available event. waitEvent :: MonadIO m => m Event waitEvent = liftIO $ alloca $ \e -> do- SDLEx.throwIfNeg_ "SDL.Events.waitEvent" "SDL_WaitEvent" $+ throwIfNeg_ "SDL.Events.waitEvent" "SDL_WaitEvent" $ Raw.waitEvent e peek e >>= convertRaw @@ -717,14 +811,119 @@ then return Nothing else fmap Just (peek e >>= convertRaw) +-- | A user defined event structure that has been registered with SDL.+--+-- Use 'registerEvent', below, to obtain an instance.+data RegisteredEventType a =+ RegisteredEventType {pushRegisteredEvent :: a -> IO EventPushResult+ ,getRegisteredEvent :: Event -> IO (Maybe a)+ }++-- | A record used to convert between SDL Events and user-defined data structures.+--+-- Used for 'registerEvent', below.+data RegisteredEventData =+ RegisteredEventData {registeredEventWindow :: !(Maybe Window)+ -- ^ The associated 'Window'.+ ,registeredEventCode :: !Int32+ -- ^ User defined event code.+ ,registeredEventData1 :: !(Ptr ())+ -- ^ User defined data pointer.+ ,registeredEventData2 :: !(Ptr ())+ -- ^ User defined data pointer.+ }+ deriving (Eq,Ord,Generic,Show,Typeable)++-- | A registered event with no associated data.+--+-- This is a resonable baseline to modify for converting to+-- 'RegisteredEventData'.+emptyRegisteredEvent :: RegisteredEventData+emptyRegisteredEvent = RegisteredEventData Nothing 0 nullPtr nullPtr++-- | Possible results of an attempted push of an event to the queue.+data EventPushResult = EventPushSuccess | EventPushFiltered | EventPushFailure Text+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++-- | Register a new event type with SDL.+--+-- Provide functions that convert between 'UserEventData' and your structure.+-- You can then use 'pushRegisteredEvent' to add a custom event of the+-- registered type to the queue, and 'getRegisteredEvent' to test for such+-- events in the main loop.+registerEvent :: MonadIO m+ => (RegisteredEventData -> Timestamp -> IO (Maybe a))+ -> (a -> IO RegisteredEventData)+ -> m (Maybe (RegisteredEventType a))+registerEvent registeredEventDataToEvent eventToRegisteredEventData = do+ typ <- Raw.registerEvents 1+ if typ == maxBound+ then return Nothing+ else+ let pushEv ev = do+ RegisteredEventData mWin code d1 d2 <- eventToRegisteredEventData ev+ windowID <- case mWin of+ Just (Window w) -> Raw.getWindowID w+ Nothing -> return 0+ -- timestamp will be filled in by SDL+ let rawEvent = Raw.UserEvent typ 0 windowID code d1 d2+ liftIO . alloca $ \eventPtr -> do+ poke eventPtr rawEvent+ pushResult <- Raw.pushEvent eventPtr+ case pushResult of+ 1 -> return $ EventPushSuccess+ 0 -> return $ EventPushFiltered+ _ -> EventPushFailure <$> getError++ getEv (Event ts (UserEvent (UserEventData _typ mWin code d1 d2))) =+ registeredEventDataToEvent (RegisteredEventData mWin code d1 d2) ts+ getEv _ = return Nothing++ in return . Just $ RegisteredEventType pushEv getEv+ -- | Pump the event loop, gathering events from the input devices. -- -- This function updates the event queue and internal input device state. ----- This should only be run in the thread that initialized the video subsystem, and for extra safety, you should consider only doing those things on the main thread in any case.+-- This should only be run in the OS thread that initialized the video subsystem, and for extra safety, you should consider only doing those things on the main thread in any case. -- -- 'pumpEvents' gathers all the pending input information from devices and places it in the event queue. Without calls to 'pumpEvents' no events would ever be placed on the queue. Often the need for calls to 'pumpEvents' is hidden from the user since 'pollEvent' and 'waitEvent' implicitly call 'pumpEvents'. However, if you are not polling or waiting for events (e.g. you are filtering them), then you must call 'pumpEvents' to force an event queue update. ----- See @<https://wiki.libsdl.org/SDL_PumpEvents SDL_PumpEvents>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_PumpEvents SDL_PumpEvents>@ for C documentation. pumpEvents :: MonadIO m => m () pumpEvents = Raw.pumpEvents++-- | An 'EventWatchCallback' can process and respond to an event+-- when it is added to the event queue.+type EventWatchCallback = Event -> IO ()+newtype EventWatch = EventWatch {runEventWatchRemoval :: IO ()}++-- | Trigger an 'EventWatchCallback' when an event is added to the SDL+-- event queue.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_AddEventWatch>@ for C documentation.+addEventWatch :: MonadIO m => EventWatchCallback -> m EventWatch+addEventWatch callback = liftIO $ do+ rawFilter <- Raw.mkEventFilter wrappedCb+ Raw.addEventWatch rawFilter nullPtr+ return (EventWatch $ auxRemove rawFilter)+ where+ wrappedCb :: Ptr () -> Ptr Raw.Event -> IO CInt+ wrappedCb _ evPtr = 0 <$ (callback =<< convertRaw =<< peek evPtr)++ auxRemove :: Raw.EventFilter -> IO ()+ auxRemove rawFilter = do+ Raw.delEventWatch rawFilter nullPtr+ freeHaskellFunPtr rawFilter++-- | Remove an 'EventWatch'.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_DelEventWatch>@ for C documentation.+delEventWatch :: MonadIO m => EventWatch -> m ()+delEventWatch = liftIO . runEventWatchRemoval++-- | Checks raw Windows for null references.+getWindowFromID :: MonadIO m => Word32 -> m (Maybe Window)+getWindowFromID windowId = do+ rawWindow <- Raw.getWindowFromID windowId+ return $ if rawWindow == nullPtr then Nothing else Just $ Window rawWindow
src/SDL/Exception.hs view
@@ -1,38 +1,16 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module SDL.Exception ( SDLException(..)- , fromC- , getError- , throwIf- , throwIf_- , throwIf0- , throwIfNeg- , throwIfNeg_- , throwIfNot0- , throwIfNot0_- , throwIfNull ) where import Control.Exception-import Control.Monad-import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Data (Data)-import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Typeable (Typeable)-import Foreign (Ptr, nullPtr) import GHC.Generics (Generic)-import qualified Data.ByteString as BS-import qualified Data.Text.Encoding as Text-import qualified SDL.Raw as Raw -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif- -- | Error details about a failure to call an SDL routine. Almost all functions in this library have the -- ability to produce exceptions of this type. Inspection should help you learn more about what has -- gone wrong.@@ -65,43 +43,3 @@ deriving (Data,Eq,Generic,Ord,Read,Show,Typeable) instance Exception SDLException--getError :: MonadIO m => m Text-getError = liftIO $ do- cstr <- Raw.getError- Text.decodeUtf8 <$> BS.packCString cstr--throwIf :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m a-throwIf f caller funName m = do- a <- m- liftIO $ when (f a) $- (SDLCallFailed caller funName <$> getError) >>= throwIO- return a--throwIf_ :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m ()-throwIf_ f caller funName m = throwIf f caller funName m >> return ()--throwIfNeg :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m a-throwIfNeg = throwIf (< 0)--throwIfNeg_ :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m ()-throwIfNeg_ = throwIf_ (< 0)--throwIfNull :: (MonadIO m) => Text -> Text -> m (Ptr a) -> m (Ptr a)-throwIfNull = throwIf (== nullPtr)--throwIf0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a-throwIf0 = throwIf (== 0)--throwIfNot0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a-throwIfNot0 = throwIf (/= 0)--throwIfNot0_ :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m ()-throwIfNot0_ = throwIf_ (/= 0)--fromC :: Show a => Text -> Text -> (a -> Maybe b) -> a -> b-fromC caller funName f x =- fromMaybe (throw (SDLUnexpectedArgument caller- funName- (show x)))- (f x)
src/SDL/Filesystem.hs view
@@ -11,7 +11,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import Foreign.Marshal.Alloc-import SDL.Exception+import SDL.Internal.Exception import qualified Data.ByteString as BS import qualified Data.Text.Encoding as Text import qualified SDL.Raw.Filesystem as Raw
src/SDL/Hint.hs view
@@ -136,12 +136,12 @@ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) -- | The 'Hint' type exports a well-typed interface to SDL's concept of--- <https://wiki.libsdl.org/CategoryHints hints>. This type has instances for+-- <https://wiki.libsdl.org/SDL2/CategoryHints hints>. This type has instances for -- both 'HasGetter' and 'HasSetter', allowing you to get and set hints. Note that -- the 'HasSetter' interface is fairly relaxed - if a hint cannot be set, the -- failure will be silently discarded. For more feedback and control when setting -- hints, see 'setHintWithPriority'.-data Hint :: * -> * where+data Hint v where HintAccelerometerAsJoystick :: Hint AccelerometerJoystickOptions HintFramebufferAcceleration :: Hint FramebufferAccelerationOptions HintMacCTRLClick :: Hint MacCTRLClickOptions
src/SDL/Init.hs view
@@ -21,7 +21,7 @@ import Foreign.Marshal.Alloc import Foreign.Storable import GHC.Generics-import SDL.Exception+import SDL.Internal.Exception import SDL.Internal.Numbered import qualified SDL.Raw as Raw @@ -29,7 +29,6 @@ import Data.Foldable #endif -{-# DEPRECATED InitEverything "Instead of initialize [InitEverything], use initializeAll" #-} data InitFlag = InitTimer | InitAudio@@ -38,7 +37,6 @@ | InitHaptic | InitGameController | InitEvents- | InitEverything deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) instance ToNumber InitFlag Word32 where@@ -49,7 +47,6 @@ toNumber InitHaptic = Raw.SDL_INIT_HAPTIC toNumber InitGameController = Raw.SDL_INIT_GAMECONTROLLER toNumber InitEvents = Raw.SDL_INIT_EVENTS- toNumber InitEverything = Raw.SDL_INIT_EVERYTHING -- | Initializes SDL and the given subsystems. Do not call any SDL functions -- prior to this one, unless otherwise documented that you may do so.
+ src/SDL/Input/GameController.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module SDL.Input.GameController+ ( ControllerDevice (..)+ , GameController+ , JoystickIndex+ , Raw.JoystickID++ , isGameController+ , mkControllerDevice+ , mkControllerDevice'+ , controllerFromInstanceID+ , availableControllers+ , openController+ , closeController+ , controllerAttached++ , getControllerID++ , controllerMapping+ , addControllerMapping+ , addControllerMappingsFromFile++ , ControllerButton (..)+ , ControllerButtonState (..)+ , controllerButton++ , ControllerAxis (..)+ , controllerAxis+ + , ControllerDeviceConnection (..)+ ) where++import Control.Monad (guard)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Maybe (runMaybeT)+import Data.Data (Data)+import Data.Int+import Data.Text (Text)+import Data.Typeable+import Data.Word+import Foreign.C (withCString)+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import GHC.Generics (Generic)+import GHC.Int (Int32)+import SDL.Input.Joystick (numJoysticks)+import SDL.Internal.Exception+import SDL.Internal.Numbered+import SDL.Internal.Types+import SDL.Vect+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified SDL.Raw as Raw+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as V++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++type JoystickIndex = CInt++{- | A description of game controller that can be opened using 'openController'.+ To retrieve a list of connected game controllers, use 'availableControllers'.+-}+data ControllerDevice = ControllerDevice+ { gameControllerDeviceName :: Text+ , gameControllerDeviceId :: JoystickIndex+ }+ deriving (Eq, Generic, Read, Ord, Show, Typeable)+++{- | Check if the given joystick is supported by the game controller interface.++ See @<https://wiki.libsdl.org/SDL2/SDL_IsGameController SDL_IsGameController>@ for C documentation.+-}+isGameController :: MonadIO m => JoystickIndex -> m Bool+isGameController = Raw.isGameController++{- | Create a 'ControllerDevice' from a 'JoystickIndex'. Returns 'Nothing' if + the 'JoystickIndex' does not support the game controller interface.+-}+mkControllerDevice :: MonadIO m => JoystickIndex -> m (Maybe ControllerDevice)+mkControllerDevice i = runMaybeT $ do+ isGC <- isGameController i+ guard isGC+ mkControllerDevice' i++{- | Create a 'ControllerDevice' from a 'JoystickIndex'. Does not check whether+ the 'JoystickIndex' supports the game controller interface.+-}+mkControllerDevice' :: MonadIO m => JoystickIndex -> m ControllerDevice+mkControllerDevice' i = do+ cstr <- liftIO $+ throwIfNull "SDL.Input.GameController.mkControllerDevice'" "SDL_GameControllerNameForIndex" $+ Raw.gameControllerNameForIndex (fromIntegral i)+ name <- liftIO $ Text.decodeUtf8 <$> BS.packCString cstr+ return (ControllerDevice name i)++{- | Get the 'GameController' associated with a 'Raw.JoystickID'.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerFromInstanceID SDL_GameControllerFromInstanceID>@ for C documentation.+-}+controllerFromInstanceID :: MonadIO m => Raw.JoystickID -> m GameController+controllerFromInstanceID i =+ fmap GameController $+ throwIfNull "SDL.Input.GameController.controllerFromInstanceID" "SDL_GameControllerFromInstanceID" $+ Raw.gameControllerFromInstanceID (fromIntegral i)+++-- | Enumerate all connected Controllers, retrieving a description of each.+availableControllers :: MonadIO m => m (V.Vector ControllerDevice)+availableControllers = liftIO $ do+ n <- fromIntegral <$> numJoysticks+ V.catMaybes <$> V.generateM n (mkControllerDevice . fromIntegral)++{- | Open a controller so that you can start receiving events from interaction with this controller.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerOpen SDL_GameControllerOpen>@ for C documentation.+-}+openController+ :: (Functor m, MonadIO m)+ => ControllerDevice+ -- ^ The device to open. Use 'availableControllers' to find 'JoystickDevices's+ -> m GameController+openController (ControllerDevice _ i) =+ fmap GameController $+ throwIfNull "SDL.Input.GameController.openController" "SDL_GameControllerOpen" $+ Raw.gameControllerOpen (fromIntegral i)++{- | Close a controller previously opened with 'openController'.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerClose SDL_GameControllerClose>@ for C documentation.+-}+closeController :: MonadIO m => GameController -> m ()+closeController (GameController j) = Raw.gameControllerClose j++{- | Check if a controller has been opened and is currently connected.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerGetAttached SDL_GameControllerGetAttached>@ for C documentation.+-}+controllerAttached :: MonadIO m => GameController -> m Bool+controllerAttached (GameController c) = Raw.gameControllerGetAttached c++{- | Get the instance ID of an opened controller. The instance ID is used to identify the controller+ in future SDL events.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerInstanceID SDL_GameControllerInstanceID>@ for C documentation.+-}+getControllerID :: MonadIO m => GameController -> m Raw.JoystickID+getControllerID (GameController c) =+ throwIfNeg "SDL.Input.GameController.getControllerID" "SDL_JoystickInstanceID" $+ Raw.joystickInstanceID c++{- | Get the current mapping of a Game Controller.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerMapping SDL_GameControllerMapping>@ for C documentation.+-}+controllerMapping :: MonadIO m => GameController -> m Text+controllerMapping (GameController c) = liftIO $ do+ mapping <-+ throwIfNull "SDL.Input.GameController.getControllerMapping" "SDL_GameControllerMapping" $+ Raw.gameControllerMapping c+ Text.decodeUtf8 <$> BS.packCString mapping++{- | Add support for controllers that SDL is unaware of or to cause an existing controller to+ have a different binding.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerAddMapping SDL_GameControllerAddMapping>@ for C documentation.+-}+addControllerMapping :: MonadIO m => BS.ByteString -> m ()+addControllerMapping mapping =+ liftIO $+ throwIfNeg_ "SDL.Input.GameController.addControllerMapping" "SDL_GameControllerAddMapping" $+ let (mappingForeign, _, _) = BSI.toForeignPtr mapping+ in withForeignPtr mappingForeign $ \mappingPtr ->+ Raw.gameControllerAddMapping (castPtr mappingPtr)++{- | Use this function to load a set of Game Controller mappings from a file, filtered by the+ current SDL_GetPlatform(). A community sourced database of controllers is available+ @<https://raw.githubusercontent.com/gabomdq/SDL_GameControllerDB/master/gamecontrollerdb.txt here>@+ (on GitHub).++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerAddMappingsFromFile SDL_GameControllerAddMappingsFromFile>@ for C documentation.+-}+addControllerMappingsFromFile :: MonadIO m => FilePath -> m ()+addControllerMappingsFromFile mappingFile =+ liftIO $+ throwIfNeg_ "SDL.Input.GameController.addControllerMappingsFromFile" "SDL_GameControllerAddMappingsFromFile" $+ withCString mappingFile Raw.gameControllerAddMappingsFromFile++{- | Get the current state of an axis control on a game controller.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerGetAxis SDL_GameControllerGetAxis>@ for C documentation.+-}+controllerAxis :: MonadIO m => GameController -> ControllerAxis -> m Int16+controllerAxis (GameController c) axis =+ Raw.gameControllerGetAxis c (toNumber axis)++{- | Get the current state of a button on a game controller.++ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerGetButton SDL_GameControllerGetButton>@ for C documentation.+-}+controllerButton :: MonadIO m => GameController -> ControllerButton -> m ControllerButtonState+controllerButton (GameController c) button =+ fromNumber . fromIntegral <$> Raw.gameControllerGetButton c (toNumber button)++-- | Identifies a gamepad button.+data ControllerButton+ = ControllerButtonInvalid+ | ControllerButtonA+ | ControllerButtonB+ | ControllerButtonX+ | ControllerButtonY+ | ControllerButtonBack+ | ControllerButtonGuide+ | ControllerButtonStart+ | ControllerButtonLeftStick+ | ControllerButtonRightStick+ | ControllerButtonLeftShoulder+ | ControllerButtonRightShoulder+ | ControllerButtonDpadUp+ | ControllerButtonDpadDown+ | ControllerButtonDpadLeft+ | ControllerButtonDpadRight+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber ControllerButton Int32 where+ fromNumber n = case n of+ Raw.SDL_CONTROLLER_BUTTON_A -> ControllerButtonA+ Raw.SDL_CONTROLLER_BUTTON_B -> ControllerButtonB+ Raw.SDL_CONTROLLER_BUTTON_X -> ControllerButtonX+ Raw.SDL_CONTROLLER_BUTTON_Y -> ControllerButtonY+ Raw.SDL_CONTROLLER_BUTTON_BACK -> ControllerButtonBack+ Raw.SDL_CONTROLLER_BUTTON_GUIDE -> ControllerButtonGuide+ Raw.SDL_CONTROLLER_BUTTON_START -> ControllerButtonStart+ Raw.SDL_CONTROLLER_BUTTON_LEFTSTICK -> ControllerButtonLeftStick+ Raw.SDL_CONTROLLER_BUTTON_RIGHTSTICK -> ControllerButtonRightStick+ Raw.SDL_CONTROLLER_BUTTON_LEFTSHOULDER -> ControllerButtonLeftShoulder+ Raw.SDL_CONTROLLER_BUTTON_RIGHTSHOULDER -> ControllerButtonRightShoulder+ Raw.SDL_CONTROLLER_BUTTON_DPAD_UP -> ControllerButtonDpadUp+ Raw.SDL_CONTROLLER_BUTTON_DPAD_DOWN -> ControllerButtonDpadDown+ Raw.SDL_CONTROLLER_BUTTON_DPAD_LEFT -> ControllerButtonDpadLeft+ Raw.SDL_CONTROLLER_BUTTON_DPAD_RIGHT -> ControllerButtonDpadRight+ _ -> ControllerButtonInvalid++instance ToNumber ControllerButton Int32 where+ toNumber c = case c of+ ControllerButtonA -> Raw.SDL_CONTROLLER_BUTTON_A+ ControllerButtonB -> Raw.SDL_CONTROLLER_BUTTON_B+ ControllerButtonX -> Raw.SDL_CONTROLLER_BUTTON_X+ ControllerButtonY -> Raw.SDL_CONTROLLER_BUTTON_Y+ ControllerButtonBack -> Raw.SDL_CONTROLLER_BUTTON_BACK+ ControllerButtonGuide -> Raw.SDL_CONTROLLER_BUTTON_GUIDE+ ControllerButtonStart -> Raw.SDL_CONTROLLER_BUTTON_START+ ControllerButtonLeftStick -> Raw.SDL_CONTROLLER_BUTTON_LEFTSTICK+ ControllerButtonRightStick -> Raw.SDL_CONTROLLER_BUTTON_RIGHTSTICK+ ControllerButtonLeftShoulder -> Raw.SDL_CONTROLLER_BUTTON_LEFTSHOULDER+ ControllerButtonRightShoulder -> Raw.SDL_CONTROLLER_BUTTON_RIGHTSHOULDER+ ControllerButtonDpadUp -> Raw.SDL_CONTROLLER_BUTTON_DPAD_UP+ ControllerButtonDpadDown -> Raw.SDL_CONTROLLER_BUTTON_DPAD_DOWN+ ControllerButtonDpadLeft -> Raw.SDL_CONTROLLER_BUTTON_DPAD_LEFT+ ControllerButtonDpadRight -> Raw.SDL_CONTROLLER_BUTTON_DPAD_RIGHT+ ControllerButtonInvalid -> Raw.SDL_CONTROLLER_BUTTON_INVALID++-- | Identifies the state of a controller button.+data ControllerButtonState+ = ControllerButtonPressed+ | ControllerButtonReleased+ | ControllerButtonInvalidState+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber ControllerButtonState Word32 where+ fromNumber n = case n of+ Raw.SDL_CONTROLLERBUTTONDOWN -> ControllerButtonPressed+ Raw.SDL_CONTROLLERBUTTONUP -> ControllerButtonReleased+ _ -> ControllerButtonInvalidState++data ControllerAxis+ = ControllerAxisInvalid+ | ControllerAxisLeftX+ | ControllerAxisLeftY+ | ControllerAxisRightX+ | ControllerAxisRightY+ | ControllerAxisTriggerLeft+ | ControllerAxisTriggerRight+ | ControllerAxisMax+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance ToNumber ControllerAxis Int32 where+ toNumber a = case a of+ ControllerAxisLeftX -> Raw.SDL_CONTROLLER_AXIS_LEFTX+ ControllerAxisLeftY -> Raw.SDL_CONTROLLER_AXIS_LEFTY+ ControllerAxisRightX -> Raw.SDL_CONTROLLER_AXIS_RIGHTX+ ControllerAxisRightY -> Raw.SDL_CONTROLLER_AXIS_RIGHTY+ ControllerAxisTriggerLeft -> Raw.SDL_CONTROLLER_AXIS_TRIGGERLEFT+ ControllerAxisTriggerRight -> Raw.SDL_CONTROLLER_AXIS_TRIGGERRIGHT+ ControllerAxisMax -> Raw.SDL_CONTROLLER_AXIS_MAX+ ControllerAxisInvalid -> Raw.SDL_CONTROLLER_AXIS_INVALID++instance FromNumber ControllerAxis Int32 where+ fromNumber n = case n of+ Raw.SDL_CONTROLLER_AXIS_LEFTX -> ControllerAxisLeftX+ Raw.SDL_CONTROLLER_AXIS_LEFTY -> ControllerAxisLeftY+ Raw.SDL_CONTROLLER_AXIS_RIGHTX -> ControllerAxisRightX+ Raw.SDL_CONTROLLER_AXIS_RIGHTY -> ControllerAxisRightY+ Raw.SDL_CONTROLLER_AXIS_TRIGGERLEFT -> ControllerAxisTriggerLeft+ Raw.SDL_CONTROLLER_AXIS_TRIGGERRIGHT -> ControllerAxisTriggerRight+ Raw.SDL_CONTROLLER_AXIS_MAX -> ControllerAxisMax+ _ -> ControllerAxisInvalid++-- | Identifies whether the game controller was added, removed, or remapped.+data ControllerDeviceConnection+ = ControllerDeviceAdded+ | ControllerDeviceRemoved+ | ControllerDeviceRemapped+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber ControllerDeviceConnection Word32 where+ fromNumber n = case n of+ Raw.SDL_CONTROLLERDEVICEADDED -> ControllerDeviceAdded+ Raw.SDL_CONTROLLERDEVICEREMOVED -> ControllerDeviceRemoved+ _ -> ControllerDeviceRemapped
src/SDL/Input/Joystick.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} module SDL.Input.Joystick ( numJoysticks@@ -13,25 +15,33 @@ , getJoystickID , Joystick+ , JoyButtonState(..) , buttonPressed , ballDelta , axisPosition , numAxes , numButtons , numBalls+ , JoyHatPosition(..)+ , getHat+ , numHats+ , JoyDeviceConnection(..) ) where import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Data (Data) import Data.Int import Data.Text (Text) import Data.Traversable (for) import Data.Typeable+import Data.Word import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Storable import GHC.Generics (Generic) import SDL.Vect-import SDL.Exception+import SDL.Internal.Exception+import SDL.Internal.Numbered import SDL.Internal.Types import qualified Data.ByteString as BS import qualified Data.Text.Encoding as Text@@ -49,9 +59,19 @@ , joystickDeviceId :: CInt } deriving (Eq, Generic, Read, Ord, Show, Typeable) +-- | Identifies the state of a joystick button.+data JoyButtonState = JoyButtonPressed | JoyButtonReleased+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber JoyButtonState Word8 where+ fromNumber n = case n of+ Raw.SDL_PRESSED -> JoyButtonPressed+ Raw.SDL_RELEASED -> JoyButtonReleased+ _ -> JoyButtonReleased+ -- | Count the number of joysticks attached to the system. ----- See @<https://wiki.libsdl.org/SDL_NumJoysticks SDL_NumJoysticks>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_NumJoysticks SDL_NumJoysticks>@ for C documentation. numJoysticks :: MonadIO m => m (CInt) numJoysticks = throwIfNeg "SDL.Input.Joystick.availableJoysticks" "SDL_NumJoysticks" Raw.numJoysticks @@ -69,7 +89,7 @@ -- | Open a joystick so that you can start receiving events from interaction with this joystick. ----- See @<https://wiki.libsdl.org/SDL_JoystickOpen SDL_JoystickOpen>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickOpen SDL_JoystickOpen>@ for C documentation. openJoystick :: (Functor m,MonadIO m) => JoystickDevice -- ^ The device to open. Use 'availableJoysticks' to find 'JoystickDevices's -> m Joystick@@ -80,23 +100,23 @@ -- | Close a joystick previously opened with 'openJoystick'. ----- See @<https://wiki.libsdl.org/SDL_JoystickClose SDL_JoystickClose>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickClose SDL_JoystickClose>@ for C documentation. closeJoystick :: MonadIO m => Joystick -> m () closeJoystick (Joystick j) = Raw.joystickClose j -- | Get the instance ID of an opened joystick. The instance ID is used to identify the joystick -- in future SDL events. ----- See @<https://wiki.libsdl.org/SDL_JoystickInstanceID SDL_JoystickInstanceID>@ for C documentation.-getJoystickID :: MonadIO m => Joystick -> m (Int32)+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickInstanceID SDL_JoystickInstanceID>@ for C documentation.+getJoystickID :: MonadIO m => Joystick -> m Raw.JoystickID getJoystickID (Joystick j) = throwIfNeg "SDL.Input.Joystick.getJoystickID" "SDL_JoystickInstanceID" $ Raw.joystickInstanceID j -- | Determine if a given button is currently held. ----- See @<https://wiki.libsdl.org/SDL_JoystickGetButton SDL_JoystickGetButton>@ for C documentation.-buttonPressed :: (Functor m,MonadIO m)+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickGetButton SDL_JoystickGetButton>@ for C documentation.+buttonPressed :: (Functor m, MonadIO m) => Joystick -> CInt -- ^ The index of the button. You can use 'numButtons' to determine how many buttons a given joystick has. -> m Bool@@ -104,7 +124,7 @@ -- | Get the ball axis change since the last poll. ----- See @<https://wiki.libsdl.org/SDL_JoystickGetBall SDL_JoystickGetBall>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickGetBall SDL_JoystickGetBall>@ for C documentation. ballDelta :: MonadIO m => Joystick -> CInt -- ^ The index of the joystick ball. You can use 'numBalls' to determine how many balls a given joystick has.@@ -125,24 +145,75 @@ -- -- Some joysticks use axes 2 and 3 for extra buttons. ----- See @<https://wiki.libsdl.org/SDL_JoystickGetAxis SDL_JoystickGetAxis>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickGetAxis SDL_JoystickGetAxis>@ for C documentation. axisPosition :: MonadIO m => Joystick -> CInt -> m Int16 axisPosition (Joystick j) axisIndex = Raw.joystickGetAxis j axisIndex -- | Get the number of general axis controls on a joystick. ----- See @<https://wiki.libsdl.org/SDL_JoystickNumAxes SDL_JoystickNumAxes>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickNumAxes SDL_JoystickNumAxes>@ for C documentation. numAxes :: (MonadIO m) => Joystick -> m CInt numAxes (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numAxis" "SDL_JoystickNumAxes" (Raw.joystickNumAxes j) -- | Get the number of buttons on a joystick. ----- See @<https://wiki.libsdl.org/SDL_JoystickNumButtons SDL_JoystickNumButtons>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickNumButtons SDL_JoystickNumButtons>@ for C documentation. numButtons :: (MonadIO m) => Joystick -> m CInt numButtons (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numButtons" "SDL_JoystickNumButtons" (Raw.joystickNumButtons j) -- | Get the number of trackballs on a joystick. ----- See @<https://wiki.libsdl.org/SDL_JoystickNumBalls SDL_JoystickNumBalls>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickNumBalls SDL_JoystickNumBalls>@ for C documentation. numBalls :: (MonadIO m) => Joystick -> m CInt numBalls (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numBalls" "SDL_JoystickNumBalls" (Raw.joystickNumBalls j)++-- | Identifies the state of the POV hat on a joystick.+data JoyHatPosition+ = HatCentered -- ^ Centered position+ | HatUp -- ^ Up position+ | HatRight -- ^ Right position+ | HatDown -- ^ Down position+ | HatLeft -- ^ Left position+ | HatRightUp -- ^ Right-up position+ | HatRightDown -- ^ Right-down position+ | HatLeftUp -- ^ Left-up position+ | HatLeftDown -- ^ Left-down position+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber JoyHatPosition Word8 where+ fromNumber n = case n of+ Raw.SDL_HAT_CENTERED -> HatCentered+ Raw.SDL_HAT_UP -> HatUp+ Raw.SDL_HAT_RIGHT -> HatRight+ Raw.SDL_HAT_DOWN -> HatDown+ Raw.SDL_HAT_LEFT -> HatLeft+ Raw.SDL_HAT_RIGHTUP -> HatRightUp+ Raw.SDL_HAT_RIGHTDOWN -> HatRightDown+ Raw.SDL_HAT_LEFTUP -> HatLeftUp+ Raw.SDL_HAT_LEFTDOWN -> HatLeftDown+ _ -> HatCentered++-- | Get current position of a POV hat on a joystick.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickGetHat SDL_JoystickGetHat>@ for C documentation.+getHat :: (Functor m, MonadIO m)+ => Joystick+ -> CInt -- ^ The index of the POV hat. You can use 'numHats' to determine how many POV hats a given joystick has.+ -> m JoyHatPosition+getHat (Joystick j) hatIndex = fromNumber <$> Raw.joystickGetHat j hatIndex++-- | Get the number of POV hats on a joystick.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_JoystickNumHats SDL_JoystickNumHats>@ for C documentation.+numHats :: (MonadIO m) => Joystick -> m CInt+numHats (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numHats" "SDL_JoystickNumHats" (Raw.joystickNumHats j)++-- | Identifies whether a joystick has been connected or disconnected.+data JoyDeviceConnection = JoyDeviceAdded | JoyDeviceRemoved+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber JoyDeviceConnection Word32 where+ fromNumber n = case n of+ Raw.SDL_JOYDEVICEADDED -> JoyDeviceAdded+ Raw.SDL_JOYDEVICEREMOVED -> JoyDeviceRemoved+ _ -> JoyDeviceAdded
src/SDL/Input/Keyboard.hs view
@@ -56,7 +56,7 @@ -- | Get the current key modifier state for the keyboard. The key modifier state is a mask special keys that are held down. ----- See @<https://wiki.libsdl.org/SDL_GetModState SDL_GetModState>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetModState SDL_GetModState>@ for C documentation. getModState :: (Functor m, MonadIO m) => m KeyModifier getModState = fromNumber <$> Raw.getModState @@ -108,7 +108,7 @@ -- | Set the rectangle used to type text inputs and start accepting text input -- events. ----- See @<https://wiki.libsdl.org/SDL_StartTextInput SDL_StartTextInput>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_StartTextInput SDL_StartTextInput>@ for C documentation. startTextInput :: MonadIO m => Raw.Rect -> m () startTextInput rect = liftIO $ do alloca $ \ptr -> do@@ -118,25 +118,25 @@ -- | Stop receiving any text input events. ----- See @<https://wiki.libsdl.org/SDL_StopTextInput SDL_StopTextInput>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_StopTextInput SDL_StopTextInput>@ for C documentation. stopTextInput :: MonadIO m => m () stopTextInput = Raw.stopTextInput -- | Check whether the platform has screen keyboard support. ----- See @<https://wiki.libsdl.org/SDL_HasScreenKeyboardSupport SDL_HasScreenKeyboardSupport>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_HasScreenKeyboardSupport SDL_HasScreenKeyboardSupport>@ for C documentation. hasScreenKeyboardSupport :: MonadIO m => m Bool hasScreenKeyboardSupport = Raw.hasScreenKeyboardSupport -- | Check whether the screen keyboard is shown for the given window. ----- See @<https://wiki.libsdl.org/SDL_IsScreenKeyboardShown SDL_IsScreenKeyboardShown>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_IsScreenKeyboardShown SDL_IsScreenKeyboardShown>@ for C documentation. isScreenKeyboardShown :: MonadIO m => Window -> m Bool isScreenKeyboardShown (Window w) = Raw.isScreenKeyboardShown w -- | Get a human-readable name for a scancode. If the scancode doesn't have a name this function returns the empty string. ----- See @<https://wiki.libsdl.org/SDL_GetScancodeName SDL_GetScancodeName>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetScancodeName SDL_GetScancodeName>@ for C documentation. getScancodeName :: MonadIO m => Scancode -> m String getScancodeName scancode = liftIO $ do name <- Raw.getScancodeName $ toNumber scancode@@ -156,7 +156,7 @@ -- -- This computation generates a mapping from 'Scancode' to 'Bool' - evaluating the function at specific 'Scancode's will inform you as to whether or not that key was held down when 'getKeyboardState' was called. ----- See @<https://wiki.libsdl.org/SDL_GetKeyboardState SDL_GetKeyboardState>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetKeyboardState SDL_GetKeyboardState>@ for C documentation. getKeyboardState :: MonadIO m => m (Scancode -> Bool) getKeyboardState = liftIO $ do alloca $ \nkeys -> do
src/SDL/Input/Keyboard/Codes.hs view
@@ -1,7 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-}++#if MIN_VERSION_base(4,11,0)+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}+#endif+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-|
src/SDL/Input/Mouse.hs view
@@ -3,29 +3,27 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-} module SDL.Input.Mouse ( -- * Relative Mouse Mode LocationMode(..) , setMouseLocationMode , getMouseLocationMode- , setRelativeMouseMode --deprecated- , getRelativeMouseMode --deprecated -- * Mouse and Touch Input , MouseButton(..) , MouseDevice(..)+ , MouseScrollDirection(..) -- * Mouse State+ , ModalLocation(..) , getModalMouseLocation- , getMouseLocation --deprecated , getAbsoluteMouseLocation , getRelativeMouseLocation , getMouseButtons -- * Warping the Mouse- , WarpMouseOrigin+ , WarpMouseOrigin(..) , warpMouse -- * Cursor Visibility@@ -33,10 +31,13 @@ -- * Cursor Shape , Cursor+ , SystemCursor(..) , activeCursor , createCursor+ , createCursorFrom , freeCursor , createColorCursor+ , createSystemCursor ) where import Control.Monad (void)@@ -44,6 +45,7 @@ import Data.Bits import Data.Bool import Data.Data (Data)+import Data.List (nub) import Data.StateVar import Data.Typeable import Data.Word@@ -53,7 +55,7 @@ import Foreign.Storable import GHC.Generics (Generic) import SDL.Vect-import SDL.Exception+import SDL.Internal.Exception import SDL.Internal.Numbered import SDL.Internal.Types (Window(Window)) import SDL.Video.Renderer (Surface(Surface))@@ -66,8 +68,15 @@ import Control.Applicative #endif -data LocationMode = AbsoluteLocation | RelativeLocation deriving Eq+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif +data LocationMode+ = AbsoluteLocation+ | RelativeLocation+ deriving (Bounded, Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)+ -- | Sets the current relative mouse mode. -- -- When relative mouse mode is enabled, cursor is hidden and mouse position@@ -83,31 +92,22 @@ relativeMode <- Raw.getRelativeMouseMode return $ if relativeMode then RelativeLocation else AbsoluteLocation +data ModalLocation+ = AbsoluteModalLocation (Point V2 CInt)+ | RelativeModalLocation (V2 CInt)+ deriving (Eq, Generic, Ord, Read, Show, Typeable)+ -- | Return proper mouse location depending on mouse mode-getModalMouseLocation :: MonadIO m => m (LocationMode, Point V2 CInt)+getModalMouseLocation :: MonadIO m => m ModalLocation getModalMouseLocation = do mode <- getMouseLocationMode- location <- case mode of- RelativeLocation -> getRelativeMouseLocation- _ -> getAbsoluteMouseLocation- return (mode, location)---- deprecated-setRelativeMouseMode :: (Functor m, MonadIO m) => Bool -> m ()-{-# DEPRECATED setRelativeMouseMode "Use setMouseLocationMode instead" #-}-setRelativeMouseMode enable =- throwIfNeg_ "SDL.Input.Mouse" "SDL_SetRelativeMouseMode" $- Raw.setRelativeMouseMode enable----deprecated-getRelativeMouseMode :: MonadIO m => m Bool-{-# DEPRECATED getRelativeMouseMode "Use getMouseLocationMode instead" #-}-getRelativeMouseMode = Raw.getRelativeMouseMode----deprecated-getMouseLocation :: MonadIO m => m (Point V2 CInt)-{-# DEPRECATED getMouseLocation "Use getAbsoluteMouseLocation instead, or getModalMouseLocation to match future behavior." #-}-getMouseLocation = getAbsoluteMouseLocation+ case mode of+ AbsoluteLocation -> do+ location <- getAbsoluteMouseLocation+ return (AbsoluteModalLocation location)+ RelativeLocation -> do+ location <- getRelativeMouseLocation+ return (RelativeModalLocation location) data MouseButton = ButtonLeft@@ -118,6 +118,22 @@ | ButtonExtra !Int -- ^ An unknown mouse button. deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) +instance FromNumber MouseButton Word8 where+ fromNumber Raw.SDL_BUTTON_LEFT = ButtonLeft+ fromNumber Raw.SDL_BUTTON_MIDDLE = ButtonMiddle+ fromNumber Raw.SDL_BUTTON_RIGHT = ButtonRight+ fromNumber Raw.SDL_BUTTON_X1 = ButtonX1+ fromNumber Raw.SDL_BUTTON_X2 = ButtonX2+ fromNumber buttonCode = ButtonExtra $ fromIntegral buttonCode++instance ToNumber MouseButton Word8 where+ toNumber ButtonLeft = Raw.SDL_BUTTON_LEFT+ toNumber ButtonMiddle = Raw.SDL_BUTTON_MIDDLE+ toNumber ButtonRight = Raw.SDL_BUTTON_RIGHT+ toNumber ButtonX1 = Raw.SDL_BUTTON_X1+ toNumber ButtonX2 = Raw.SDL_BUTTON_X2+ toNumber (ButtonExtra i) = fromIntegral i+ -- | Identifies what kind of mouse-like device this is. data MouseDevice = Mouse !Int -- ^ An actual mouse. The number identifies which mouse.@@ -129,24 +145,39 @@ Raw.SDL_TOUCH_MOUSEID -> Touch n -> Mouse $ fromIntegral n +-- | Identifies mouse scroll direction.+data MouseScrollDirection+ = ScrollNormal+ | ScrollFlipped+ deriving (Bounded, Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)++instance FromNumber MouseScrollDirection Word32 where+ fromNumber n' = case n' of+ Raw.SDL_MOUSEWHEEL_NORMAL -> ScrollNormal+ Raw.SDL_MOUSEWHEEL_FLIPPED -> ScrollFlipped+ _ -> ScrollNormal+ data WarpMouseOrigin = WarpInWindow Window -- ^ Move the mouse pointer within a given 'Window'. | WarpCurrentFocus -- ^ Move the mouse pointer within whichever 'Window' currently has focus.- -- WarpGlobal -- Needs 2.0.4+ | WarpGlobal+ -- ^ Move the mouse pointer in global screen space. deriving (Data, Eq, Generic, Ord, Show, Typeable) -- | Move the current location of a mouse pointer. The 'WarpMouseOrigin' specifies the origin for the given warp coordinates. warpMouse :: MonadIO m => WarpMouseOrigin -> Point V2 CInt -> m () warpMouse (WarpInWindow (Window w)) (P (V2 x y)) = Raw.warpMouseInWindow w x y warpMouse WarpCurrentFocus (P (V2 x y)) = Raw.warpMouseInWindow nullPtr x y+warpMouse WarpGlobal (P (V2 x y)) = throwIfNeg_ "SDL.Mouse.warpMouse" "SDL_WarpMouseGlobal" $+ Raw.warpMouseGlobal x y -- | Get or set whether the cursor is currently visible. -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_ShowCursor SDL_ShowCursor>@ and @<https://wiki.libsdl.org/SDL_HideCursor SDL_HideCursor>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_ShowCursor SDL_ShowCursor>@ and @<https://wiki.libsdl.org/SDL2/SDL_HideCursor SDL_HideCursor>@ for C documentation. cursorVisible :: StateVar Bool cursorVisible = makeStateVar getCursorVisible setCursorVisible where@@ -167,12 +198,12 @@ P <$> (V2 <$> peek x <*> peek y) -- | Retrieve mouse motion-getRelativeMouseLocation :: MonadIO m => m (Point V2 CInt)+getRelativeMouseLocation :: MonadIO m => m (V2 CInt) getRelativeMouseLocation = liftIO $ alloca $ \x -> alloca $ \y -> do _ <- Raw.getRelativeMouseState x y- P <$> (V2 <$> peek x <*> peek y)+ V2 <$> peek x <*> peek y -- | Retrieve a mapping of which buttons are currently held down.@@ -180,24 +211,45 @@ getMouseButtons = liftIO $ convert <$> Raw.getMouseState nullPtr nullPtr where- convert w b = w `testBit` index- where- index = case b of- ButtonLeft -> 0- ButtonMiddle -> 1- ButtonRight -> 2- ButtonX1 -> 3- ButtonX2 -> 4- ButtonExtra i -> i+ convert w b = w `testBit` fromIntegral (toNumber b - 1) newtype Cursor = Cursor { unwrapCursor :: Raw.Cursor } deriving (Eq, Typeable) +data SystemCursor+ = SystemCursorArrow+ | SystemCursorIBeam+ | SystemCursorWait+ | SystemCursorCrossHair+ | SystemCursorWaitArrow+ | SystemCursorSizeNWSE+ | SystemCursorSizeNESW+ | SystemCursorSizeWE+ | SystemCursorSizeNS+ | SystemCursorSizeAll+ | SystemCursorNo+ | SystemCursorHand+++instance ToNumber SystemCursor Word32 where+ toNumber SystemCursorArrow = Raw.SDL_SYSTEM_CURSOR_ARROW+ toNumber SystemCursorIBeam = Raw.SDL_SYSTEM_CURSOR_IBEAM+ toNumber SystemCursorWait = Raw.SDL_SYSTEM_CURSOR_WAIT+ toNumber SystemCursorCrossHair = Raw.SDL_SYSTEM_CURSOR_CROSSHAIR+ toNumber SystemCursorWaitArrow = Raw.SDL_SYSTEM_CURSOR_WAITARROW+ toNumber SystemCursorSizeNWSE = Raw.SDL_SYSTEM_CURSOR_SIZENWSE+ toNumber SystemCursorSizeNESW = Raw.SDL_SYSTEM_CURSOR_SIZENESW+ toNumber SystemCursorSizeWE = Raw.SDL_SYSTEM_CURSOR_SIZEWE+ toNumber SystemCursorSizeNS = Raw.SDL_SYSTEM_CURSOR_SIZENS+ toNumber SystemCursorSizeAll = Raw.SDL_SYSTEM_CURSOR_SIZEALL+ toNumber SystemCursorNo = Raw.SDL_SYSTEM_CURSOR_NO+ toNumber SystemCursorHand = Raw.SDL_SYSTEM_CURSOR_HAND+ -- | Get or set the currently active cursor. You can create new 'Cursor's with 'createCursor'. -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetCursor SDL_SetCursor>@ and @<https://wiki.libsdl.org/SDL_GetCursor SDL_GetCursor>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetCursor SDL_SetCursor>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetCursor SDL_GetCursor>@ for C documentation. activeCursor :: StateVar Cursor activeCursor = makeStateVar getCursor setCursor where@@ -210,30 +262,96 @@ setCursor = Raw.setCursor . unwrapCursor -- | Create a cursor using the specified bitmap data and mask (in MSB format).------ createCursor :: MonadIO m- => V.Vector Bool -- ^ Whether this part of the cursor is black. Use 'False' for white and 'True' for black.- -> V.Vector Bool -- ^ Whether or not pixels are visible. Use 'True' for visible and 'False' for transparent.+ => V.Vector Word8 -- ^ Whether this part of the cursor is black. Use 'False' for white and 'True' for black.+ -> V.Vector Word8 -- ^ Whether or not pixels are visible. Use 'True' for visible and 'False' for transparent. -> V2 CInt -- ^ The width and height of the cursor. -> Point V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position -> m Cursor createCursor dta msk (V2 w h) (P (V2 hx hy)) = liftIO . fmap Cursor $ throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $- V.unsafeWith (V.map (bool 0 1) dta) $ \unsafeDta ->- V.unsafeWith (V.map (bool 0 1) msk) $ \unsafeMsk ->+ V.unsafeWith dta $ \unsafeDta ->+ V.unsafeWith msk $ \unsafeMsk -> Raw.createCursor unsafeDta unsafeMsk w h hx hy --- | Free a cursor created with 'createCursor' and 'createColorCusor'.+{- | Create a cursor from a bit art painting of it.++The number of columns must be a multiple of 8.++Symbols used: @ @ (space) - transparent, @.@ - visible black, @#@ (or anything else) - visible white.++A minimal cursor template:+@+source8x8 :: [[Char]]+source8x8 =+ [ " "+ , " "+ , " "+ , " "+ , " "+ , " "+ , " "+ , " "+ ]+@+-}+createCursorFrom :: MonadIO m+ => Point V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position+ -> [[Char]]+ -> m Cursor+createCursorFrom point source = do+ createCursor color mask (V2 w h) point+ where+ h = fromIntegral (length source)+ w = case nub $ map length source of+ [okay] ->+ fromIntegral okay+ mismatch ->+ error $ "Inconsistent row widths: " <> show mismatch++ color = packBools colorBits+ mask = packBools maskBits+ (colorBits, maskBits) = unzip $ map charToBool $ concat source++ packBools = V.fromList . boolListToWord8List++ charToBool ' ' = (False, False) -- transparent+ charToBool '.' = (True, True) -- visible black+ charToBool _ = (True, False) -- visible white++ boolListToWord8List xs =+ case xs of+ b1 : b2 : b3 : b4 : b5 : b6 : b7 : b8 : rest ->+ let+ packed =+ i b1 128 ++ i b2 64 ++ i b3 32 ++ i b4 16 ++ i b5 8 ++ i b6 4 ++ i b7 2 ++ i b8 1+ in+ packed : boolListToWord8List rest+ [] ->+ []+ _leftovers ->+ error "The number of columns must be a multiple of 8."+ where+ i True multiple = multiple+ i False _ = 0++-- | Free a cursor created with 'createCursor', 'createColorCusor' and 'createSystemCursor'. ----- See @<https://wiki.libsdl.org/SDL_FreeCursor SDL_FreeCursor>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_FreeCursor SDL_FreeCursor>@ for C documentation. freeCursor :: MonadIO m => Cursor -> m () freeCursor = Raw.freeCursor . unwrapCursor -- | Create a color cursor. ----- See @<https://wiki.libsdl.org/SDL_CreateColorCursor SDL_CreateColorCursor>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateColorCursor SDL_CreateColorCursor>@ for C documentation. createColorCursor :: MonadIO m => Surface -> Point V2 CInt -- ^ The location of the cursor hot spot@@ -242,3 +360,12 @@ liftIO . fmap Cursor $ throwIfNull "SDL.Input.Mouse.createColorCursor" "SDL_createColorCursor" $ Raw.createColorCursor surfPtr hx hy++-- | Create system cursor.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateSystemCursor SDL_CreateSystemCursor>@ for C documentation.+createSystemCursor :: MonadIO m => SystemCursor -> m Cursor+createSystemCursor sc =+ liftIO . fmap Cursor $+ throwIfNull "SDL.Input.Mouse.createSystemCursor" "SDL_CreateSystemCursor" $+ Raw.createSystemCursor (toNumber sc)
+ src/SDL/Internal/Exception.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}++module SDL.Internal.Exception+ ( fromC+ , getError+ , throwIf+ , throwIf_+ , throwIf0+ , throwIfNeg+ , throwIfNeg_+ , throwIfNot0+ , throwIfNot0_+ , throwIfNull+ ) where++import Control.Exception+import Data.Maybe (fromMaybe)+import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text (Text)+import Foreign (Ptr, nullPtr)+import SDL.Exception+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as Text+import qualified SDL.Raw as Raw++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++getError :: MonadIO m => m Text+getError = liftIO $ do+ cstr <- Raw.getError+ Text.decodeUtf8 <$> BS.packCString cstr++{-# INLINE throwIf #-}+throwIf :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m a+throwIf f caller funName m = do+ a <- m+ liftIO $ when (f a) $+ (SDLCallFailed caller funName <$> getError) >>= throwIO+ return a++{-# INLINE throwIf_ #-}+throwIf_ :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m ()+throwIf_ f caller funName m = throwIf f caller funName m >> return ()++{-# INLINE throwIfNeg #-}+throwIfNeg :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m a+throwIfNeg = throwIf (< 0)++{-# INLINE throwIfNeg_ #-}+throwIfNeg_ :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m ()+throwIfNeg_ = throwIf_ (< 0)++{-# INLINE throwIfNull #-}+throwIfNull :: (MonadIO m) => Text -> Text -> m (Ptr a) -> m (Ptr a)+throwIfNull = throwIf (== nullPtr)++{-# INLINE throwIf0 #-}+throwIf0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a+throwIf0 = throwIf (== 0)++{-# INLINE throwIfNot0 #-}+throwIfNot0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a+throwIfNot0 = throwIf (/= 0)++{-# INLINE throwIfNot0_ #-}+throwIfNot0_ :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m ()+throwIfNot0_ = throwIf_ (/= 0)++fromC :: Show a => Text -> Text -> (a -> Maybe b) -> a -> b+fromC caller funName f x =+ fromMaybe (throw (SDLUnexpectedArgument caller+ funName+ (show x)))+ (f x)
src/SDL/Internal/Types.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} module SDL.Internal.Types ( Joystick(..)+ , GameController(..) , Window(..) , Renderer(..) ) where@@ -13,6 +14,10 @@ import qualified SDL.Raw as Raw newtype Joystick = Joystick { joystickPtr :: Raw.Joystick }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++newtype GameController = GameController+ { gameControllerPtr :: Raw.GameController } deriving (Data, Eq, Generic, Ord, Show, Typeable) newtype Window = Window (Raw.Window)
src/SDL/Internal/Vect.hs view
@@ -131,7 +131,7 @@ {-# INLINE (<*>) #-} instance Monad V2 where- return a = V2 a a+ return = pure {-# INLINE return #-} V2 a b >>= f = V2 a' b' where V2 a' _ = f a@@ -311,7 +311,7 @@ {-# INLINE (<*>) #-} instance Monad V3 where- return a = V3 a a a+ return = pure {-# INLINE return #-} V3 a b c >>= f = V3 a' b' c' where V3 a' _ _ = f a@@ -504,7 +504,7 @@ {-# INLINE (<*>) #-} instance Monad V4 where- return a = V4 a a a a+ return = pure {-# INLINE return #-} V4 a b c d >>= f = V4 a' b' c' d' where V4 a' _ _ _ = f a
src/SDL/Power.hs view
@@ -27,7 +27,7 @@ -- -- Throws 'SDLException' if the current power state can not be determined. ----- See @<https://wiki.libsdl.org/SDL_GetPowerInfo SDL_GetPowerInfo>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetPowerInfo SDL_GetPowerInfo>@ for C documentation. getPowerInfo :: (Functor m, MonadIO m) => m PowerState getPowerInfo = liftIO $
src/SDL/Raw/Audio.hs view
@@ -3,6 +3,7 @@ audioInit, audioQuit, buildAudioCVT,+ clearQueuedAudio, closeAudio, closeAudioDevice, convertAudio,@@ -14,6 +15,7 @@ getCurrentAudioDriver, getNumAudioDevices, getNumAudioDrivers,+ getQueuedAudioSize, loadWAV, loadWAV_RW, lockAudio,@@ -24,6 +26,7 @@ openAudioDevice, pauseAudio, pauseAudioDevice,+ queueAudio, unlockAudio, unlockAudioDevice ) where@@ -40,6 +43,7 @@ foreign import ccall "SDL.h SDL_AudioInit" audioInitFFI :: CString -> IO CInt foreign import ccall "SDL.h SDL_AudioQuit" audioQuitFFI :: IO () foreign import ccall "SDL.h SDL_BuildAudioCVT" buildAudioCVTFFI :: Ptr AudioCVT -> AudioFormat -> Word8 -> CInt -> AudioFormat -> Word8 -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_ClearQueuedAudio" clearQueuedAudioFFI :: AudioDeviceID -> IO () foreign import ccall "SDL.h SDL_CloseAudio" closeAudioFFI :: IO () foreign import ccall "SDL.h SDL_CloseAudioDevice" closeAudioDeviceFFI :: AudioDeviceID -> IO () foreign import ccall "SDL.h SDL_ConvertAudio" convertAudioFFI :: Ptr AudioCVT -> IO CInt@@ -51,6 +55,7 @@ foreign import ccall "SDL.h SDL_GetCurrentAudioDriver" getCurrentAudioDriverFFI :: IO CString foreign import ccall "SDL.h SDL_GetNumAudioDevices" getNumAudioDevicesFFI :: CInt -> IO CInt foreign import ccall "SDL.h SDL_GetNumAudioDrivers" getNumAudioDriversFFI :: IO CInt+foreign import ccall "SDL.h SDL_GetQueuedAudioSize" getQueuedAudioSizeFFI :: AudioDeviceID -> IO Word32 foreign import ccall "SDL.h SDL_LoadWAV_RW" loadWAV_RWFFI :: Ptr RWops -> CInt -> Ptr AudioSpec -> Ptr (Ptr Word8) -> Ptr Word32 -> IO (Ptr AudioSpec) foreign import ccall "SDL.h SDL_LockAudio" lockAudioFFI :: IO () foreign import ccall "SDL.h SDL_LockAudioDevice" lockAudioDeviceFFI :: AudioDeviceID -> IO ()@@ -60,6 +65,7 @@ foreign import ccall "SDL.h SDL_OpenAudioDevice" openAudioDeviceFFI :: CString -> CInt -> Ptr AudioSpec -> Ptr AudioSpec -> CInt -> IO AudioDeviceID foreign import ccall "SDL.h SDL_PauseAudio" pauseAudioFFI :: CInt -> IO () foreign import ccall "SDL.h SDL_PauseAudioDevice" pauseAudioDeviceFFI :: AudioDeviceID -> CInt -> IO ()+foreign import ccall "SDL.h SDL_QueueAudio" queueAudioFFI :: AudioDeviceID -> Ptr () -> Word32 -> IO CInt foreign import ccall "SDL.h SDL_UnlockAudio" unlockAudioFFI :: IO () foreign import ccall "SDL.h SDL_UnlockAudioDevice" unlockAudioDeviceFFI :: AudioDeviceID -> IO () @@ -75,6 +81,10 @@ buildAudioCVT v1 v2 v3 v4 v5 v6 v7 = liftIO $ buildAudioCVTFFI v1 v2 v3 v4 v5 v6 v7 {-# INLINE buildAudioCVT #-} +clearQueuedAudio :: MonadIO m => AudioDeviceID -> m ()+clearQueuedAudio v1 = liftIO $ clearQueuedAudioFFI v1+{-# INLINE clearQueuedAudio #-}+ closeAudio :: MonadIO m => m () closeAudio = liftIO closeAudioFFI {-# INLINE closeAudio #-}@@ -119,6 +129,10 @@ getNumAudioDrivers = liftIO getNumAudioDriversFFI {-# INLINE getNumAudioDrivers #-} +getQueuedAudioSize :: MonadIO m => AudioDeviceID -> m Word32+getQueuedAudioSize v1 = liftIO $ getQueuedAudioSizeFFI v1+{-# INLINE getQueuedAudioSize #-}+ loadWAV :: MonadIO m => CString -> Ptr AudioSpec -> Ptr (Ptr Word8) -> Ptr Word32 -> m (Ptr AudioSpec) loadWAV file spec audio_buf audio_len = liftIO $ do rw <- withCString "rb" $ rwFromFile file@@ -160,6 +174,10 @@ pauseAudioDevice :: MonadIO m => AudioDeviceID -> CInt -> m () pauseAudioDevice v1 v2 = liftIO $ pauseAudioDeviceFFI v1 v2 {-# INLINE pauseAudioDevice #-}++queueAudio :: MonadIO m => AudioDeviceID -> Ptr () -> Word32 -> m CInt+queueAudio v1 v2 v3 = liftIO $ queueAudioFFI v1 v2 v3+{-# INLINE queueAudio #-} unlockAudio :: MonadIO m => m () unlockAudio = liftIO unlockAudioFFI
src/SDL/Raw/Enum.hsc view
@@ -1,5 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternSynonyms #-}++#if MIN_VERSION_base(4,11,0)+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}+#endif+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+ module SDL.Raw.Enum ( -- * Enumerations @@ -33,6 +40,27 @@ pattern SDL_BLENDMODE_ADD, pattern SDL_BLENDMODE_MOD, + -- ** Blend Operation+ BlendOperation,+ pattern SDL_BLENDOPERATION_ADD,+ pattern SDL_BLENDOPERATION_SUBTRACT,+ pattern SDL_BLENDOPERATION_REV_SUBTRACT,+ pattern SDL_BLENDOPERATION_MINIMUM,+ pattern SDL_BLENDOPERATION_MAXIMUM,++ -- ** Blend Factor+ BlendFactor,+ pattern SDL_BLENDFACTOR_ZERO,+ pattern SDL_BLENDFACTOR_ONE,+ pattern SDL_BLENDFACTOR_SRC_COLOR,+ pattern SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR,+ pattern SDL_BLENDFACTOR_SRC_ALPHA,+ pattern SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA,+ pattern SDL_BLENDFACTOR_DST_COLOR,+ pattern SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR,+ pattern SDL_BLENDFACTOR_DST_ALPHA,+ pattern SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA,+ -- ** Endian Detetection pattern SDL_BYTEORDER, pattern SDL_LIL_ENDIAN,@@ -101,6 +129,7 @@ pattern SDL_GL_CONTEXT_PROFILE_MASK, pattern SDL_GL_SHARE_WITH_CURRENT_CONTEXT, pattern SDL_GL_FRAMEBUFFER_SRGB_CAPABLE,+ pattern SDL_GL_CONTEXT_RELEASE_BEHAVIOR, -- ** Hint Priority HintPriority,@@ -120,6 +149,16 @@ pattern SDL_INIT_NOPARACHUTE, pattern SDL_INIT_EVERYTHING, + -- ** Joystick Power Level+ JoystickPowerLevel,+ pattern SDL_JOYSTICK_POWER_UNKNOWN,+ pattern SDL_JOYSTICK_POWER_EMPTY,+ pattern SDL_JOYSTICK_POWER_LOW,+ pattern SDL_JOYSTICK_POWER_MEDIUM,+ pattern SDL_JOYSTICK_POWER_FULL,+ pattern SDL_JOYSTICK_POWER_WIRED,+ pattern SDL_JOYSTICK_POWER_MAX,+ -- ** Keycode Keycode, pattern SDLK_UNKNOWN,@@ -652,6 +691,15 @@ pattern SDL_SYSTEM_CURSOR_IBEAM, pattern SDL_SYSTEM_CURSOR_WAIT, +#ifdef RECENT_ISH+ -- ** Scale mode+ ScaleMode,+ -- NB. no idea why this enum uses camel case instead of scream case+ pattern SDL_ScaleModeNearest,+ pattern SDL_ScaleModeLinear,+ pattern SDL_ScaleModeBest,+#endif+ -- ** System Cursor SystemCursor, pattern SDL_SYSTEM_CURSOR_CROSSHAIR,@@ -694,6 +742,10 @@ pattern SDL_BUTTON_X1MASK, pattern SDL_BUTTON_X2MASK, + -- ** Mouse Wheel Direction+ pattern SDL_MOUSEWHEEL_NORMAL,+ pattern SDL_MOUSEWHEEL_FLIPPED,+ -- ** Event Type pattern SDL_FIRSTEVENT, pattern SDL_QUIT,@@ -709,6 +761,7 @@ pattern SDL_KEYUP, pattern SDL_TEXTEDITING, pattern SDL_TEXTINPUT,+ pattern SDL_KEYMAPCHANGED, pattern SDL_MOUSEMOTION, pattern SDL_MOUSEBUTTONDOWN, pattern SDL_MOUSEBUTTONUP,@@ -734,6 +787,10 @@ pattern SDL_MULTIGESTURE, pattern SDL_CLIPBOARDUPDATE, pattern SDL_DROPFILE,+ pattern SDL_AUDIODEVICEADDED,+ pattern SDL_AUDIODEVICEREMOVED,+ pattern SDL_RENDER_TARGETS_RESET,+ pattern SDL_RENDER_DEVICE_RESET, pattern SDL_USEREVENT, pattern SDL_LASTEVENT, @@ -784,6 +841,10 @@ pattern SDL_GL_CONTEXT_ROBUST_ACCESS_FLAG, pattern SDL_GL_CONTEXT_RESET_ISOLATION_FLAG, + -- ** OpenGL Context Release Behavior Flag+ pattern SDL_GL_CONTEXT_RELEASE_BEHAVIOR_NONE,+ pattern SDL_GL_CONTEXT_RELEASE_BEHAVIOR_FLUSH,+ -- ** Pixel Formats pattern SDL_PIXELFORMAT_UNKNOWN, pattern SDL_PIXELFORMAT_INDEX1LSB,@@ -873,10 +934,28 @@ pattern SDL_WINDOW_FULLSCREEN_DESKTOP, pattern SDL_WINDOW_FOREIGN, pattern SDL_WINDOW_ALLOW_HIGHDPI,+ pattern SDL_WINDOW_MOUSE_CAPTURE,+ pattern SDL_WINDOW_VULKAN, -- ** Window Positioning pattern SDL_WINDOWPOS_UNDEFINED, pattern SDL_WINDOWPOS_CENTERED,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_0,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_1,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_2,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_3,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_4,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_5,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_6,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_7,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_8,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_9,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_10,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_11,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_12,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_13,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_14,+ pattern SDL_WINDOWPOS_CENTERED_DISPLAY_15, -- ** Haptic Event Types pattern SDL_HAPTIC_CONSTANT@@ -892,6 +971,8 @@ type AudioFormat = (#type SDL_AudioFormat) type AudioStatus = (#type SDL_AudioStatus) type BlendMode = (#type SDL_BlendMode)+type BlendOperation = (#type SDL_BlendOperation)+type BlendFactor = (#type SDL_BlendFactor) type Endian = CInt type EventAction = (#type SDL_eventaction) type GameControllerAxis = (#type SDL_GameControllerAxis)@@ -899,12 +980,16 @@ type GLattr = (#type SDL_GLattr) type HintPriority = (#type SDL_HintPriority) type InitFlag = Word32+type JoystickPowerLevel = (#type SDL_JoystickPowerLevel) type Keycode = (#type SDL_Keycode) type Keymod = (#type SDL_Keymod) type LogPriority = (#type SDL_LogPriority) type PowerState = (#type SDL_PowerState) type RendererFlip = (#type SDL_RendererFlip) type Scancode = (#type SDL_Scancode)+#ifdef RECENT_ISH+type ScaleMode = (#type SDL_ScaleMode)+#endif type SystemCursor = (#type SDL_SystemCursor) type ThreadPriority = (#type SDL_ThreadPriority) @@ -932,6 +1017,23 @@ pattern SDL_BLENDMODE_ADD = (#const SDL_BLENDMODE_ADD) :: BlendMode pattern SDL_BLENDMODE_MOD = (#const SDL_BLENDMODE_MOD) :: BlendMode +pattern SDL_BLENDOPERATION_ADD = (#const SDL_BLENDOPERATION_ADD) :: BlendOperation+pattern SDL_BLENDOPERATION_SUBTRACT = (#const SDL_BLENDOPERATION_SUBTRACT) :: BlendOperation+pattern SDL_BLENDOPERATION_REV_SUBTRACT = (#const SDL_BLENDOPERATION_REV_SUBTRACT) :: BlendOperation+pattern SDL_BLENDOPERATION_MINIMUM = (#const SDL_BLENDOPERATION_MINIMUM) :: BlendOperation+pattern SDL_BLENDOPERATION_MAXIMUM = (#const SDL_BLENDOPERATION_MAXIMUM) :: BlendOperation++pattern SDL_BLENDFACTOR_ZERO = (#const SDL_BLENDFACTOR_ZERO) :: BlendFactor+pattern SDL_BLENDFACTOR_ONE = (#const SDL_BLENDFACTOR_ONE) :: BlendFactor+pattern SDL_BLENDFACTOR_SRC_COLOR = (#const SDL_BLENDFACTOR_SRC_COLOR) :: BlendFactor+pattern SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR = (#const SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR) :: BlendFactor+pattern SDL_BLENDFACTOR_SRC_ALPHA = (#const SDL_BLENDFACTOR_SRC_ALPHA) :: BlendFactor+pattern SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA = (#const SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA) :: BlendFactor+pattern SDL_BLENDFACTOR_DST_COLOR = (#const SDL_BLENDFACTOR_DST_COLOR) :: BlendFactor+pattern SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR = (#const SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR) :: BlendFactor+pattern SDL_BLENDFACTOR_DST_ALPHA = (#const SDL_BLENDFACTOR_DST_ALPHA) :: BlendFactor+pattern SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA = (#const SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA) :: BlendFactor+ pattern SDL_BYTEORDER = (#const SDL_BYTEORDER) :: Endian pattern SDL_LIL_ENDIAN = (#const SDL_LIL_ENDIAN) :: Endian pattern SDL_BIG_ENDIAN = (#const SDL_BIG_ENDIAN) :: Endian@@ -991,6 +1093,7 @@ pattern SDL_GL_CONTEXT_PROFILE_MASK = (#const SDL_GL_CONTEXT_PROFILE_MASK) :: GLattr pattern SDL_GL_SHARE_WITH_CURRENT_CONTEXT = (#const SDL_GL_SHARE_WITH_CURRENT_CONTEXT) :: GLattr pattern SDL_GL_FRAMEBUFFER_SRGB_CAPABLE = (#const SDL_GL_FRAMEBUFFER_SRGB_CAPABLE) :: GLattr+pattern SDL_GL_CONTEXT_RELEASE_BEHAVIOR = (#const SDL_GL_CONTEXT_RELEASE_BEHAVIOR) :: GLattr pattern SDL_HINT_DEFAULT = (#const SDL_HINT_DEFAULT) :: HintPriority pattern SDL_HINT_NORMAL = (#const SDL_HINT_NORMAL) :: HintPriority@@ -1006,6 +1109,14 @@ pattern SDL_INIT_NOPARACHUTE = (#const SDL_INIT_NOPARACHUTE) :: InitFlag pattern SDL_INIT_EVERYTHING = (#const SDL_INIT_EVERYTHING) :: InitFlag +pattern SDL_JOYSTICK_POWER_UNKNOWN = (#const SDL_JOYSTICK_POWER_UNKNOWN) :: JoystickPowerLevel+pattern SDL_JOYSTICK_POWER_EMPTY = (#const SDL_JOYSTICK_POWER_EMPTY) :: JoystickPowerLevel+pattern SDL_JOYSTICK_POWER_LOW = (#const SDL_JOYSTICK_POWER_LOW) :: JoystickPowerLevel+pattern SDL_JOYSTICK_POWER_MEDIUM = (#const SDL_JOYSTICK_POWER_MEDIUM) :: JoystickPowerLevel+pattern SDL_JOYSTICK_POWER_FULL = (#const SDL_JOYSTICK_POWER_FULL) :: JoystickPowerLevel+pattern SDL_JOYSTICK_POWER_WIRED = (#const SDL_JOYSTICK_POWER_WIRED) :: JoystickPowerLevel+pattern SDL_JOYSTICK_POWER_MAX = (#const SDL_JOYSTICK_POWER_MAX) :: JoystickPowerLevel+ pattern SDLK_UNKNOWN = (#const SDLK_UNKNOWN) :: Keycode pattern SDLK_RETURN = (#const SDLK_RETURN) :: Keycode pattern SDLK_ESCAPE = (#const SDLK_ESCAPE) :: Keycode@@ -1522,6 +1633,12 @@ pattern SDL_SCANCODE_APP2 = (#const SDL_SCANCODE_APP2) :: Scancode pattern SDL_NUM_SCANCODES = (#const SDL_NUM_SCANCODES) :: Scancode +#ifdef RECENT_ISH+pattern SDL_ScaleModeNearest = (#const SDL_ScaleModeNearest) :: ScaleMode+pattern SDL_ScaleModeLinear = (#const SDL_ScaleModeLinear) :: ScaleMode+pattern SDL_ScaleModeBest = (#const SDL_ScaleModeBest) :: ScaleMode+#endif+ pattern SDL_SYSTEM_CURSOR_ARROW = (#const SDL_SYSTEM_CURSOR_ARROW) :: SystemCursor pattern SDL_SYSTEM_CURSOR_IBEAM = (#const SDL_SYSTEM_CURSOR_IBEAM) :: SystemCursor pattern SDL_SYSTEM_CURSOR_WAIT = (#const SDL_SYSTEM_CURSOR_WAIT) :: SystemCursor@@ -1556,6 +1673,9 @@ pattern SDL_BUTTON_X1MASK = (#const SDL_BUTTON_X1MASK) pattern SDL_BUTTON_X2MASK = (#const SDL_BUTTON_X2MASK) +pattern SDL_MOUSEWHEEL_NORMAL = (#const SDL_MOUSEWHEEL_NORMAL)+pattern SDL_MOUSEWHEEL_FLIPPED = (#const SDL_MOUSEWHEEL_FLIPPED)+ pattern SDL_FIRSTEVENT = (#const SDL_FIRSTEVENT) pattern SDL_QUIT = (#const SDL_QUIT) pattern SDL_APP_TERMINATING = (#const SDL_APP_TERMINATING)@@ -1570,6 +1690,7 @@ pattern SDL_KEYUP = (#const SDL_KEYUP) pattern SDL_TEXTEDITING = (#const SDL_TEXTEDITING) pattern SDL_TEXTINPUT = (#const SDL_TEXTINPUT)+pattern SDL_KEYMAPCHANGED = (#const SDL_KEYMAPCHANGED) pattern SDL_MOUSEMOTION = (#const SDL_MOUSEMOTION) pattern SDL_MOUSEBUTTONDOWN = (#const SDL_MOUSEBUTTONDOWN) pattern SDL_MOUSEBUTTONUP = (#const SDL_MOUSEBUTTONUP)@@ -1595,6 +1716,10 @@ pattern SDL_MULTIGESTURE = (#const SDL_MULTIGESTURE) pattern SDL_CLIPBOARDUPDATE = (#const SDL_CLIPBOARDUPDATE) pattern SDL_DROPFILE = (#const SDL_DROPFILE)+pattern SDL_AUDIODEVICEADDED = (#const SDL_AUDIODEVICEADDED)+pattern SDL_AUDIODEVICEREMOVED = (#const SDL_AUDIODEVICEREMOVED)+pattern SDL_RENDER_TARGETS_RESET = (#const SDL_RENDER_TARGETS_RESET)+pattern SDL_RENDER_DEVICE_RESET = (#const SDL_RENDER_DEVICE_RESET) pattern SDL_USEREVENT = (#const SDL_USEREVENT) pattern SDL_LASTEVENT = (#const SDL_LASTEVENT) @@ -1638,6 +1763,9 @@ pattern SDL_GL_CONTEXT_ROBUST_ACCESS_FLAG = (#const SDL_GL_CONTEXT_ROBUST_ACCESS_FLAG) pattern SDL_GL_CONTEXT_RESET_ISOLATION_FLAG = (#const SDL_GL_CONTEXT_RESET_ISOLATION_FLAG) +pattern SDL_GL_CONTEXT_RELEASE_BEHAVIOR_NONE = (#const SDL_GL_CONTEXT_RELEASE_BEHAVIOR_NONE)+pattern SDL_GL_CONTEXT_RELEASE_BEHAVIOR_FLUSH = (#const SDL_GL_CONTEXT_RELEASE_BEHAVIOR_FLUSH)+ pattern SDL_PIXELFORMAT_UNKNOWN = (#const SDL_PIXELFORMAT_UNKNOWN) pattern SDL_PIXELFORMAT_INDEX1LSB = (#const SDL_PIXELFORMAT_INDEX1LSB) pattern SDL_PIXELFORMAT_INDEX1MSB = (#const SDL_PIXELFORMAT_INDEX1MSB)@@ -1720,8 +1848,26 @@ pattern SDL_WINDOW_FULLSCREEN_DESKTOP = (#const SDL_WINDOW_FULLSCREEN_DESKTOP) pattern SDL_WINDOW_FOREIGN = (#const SDL_WINDOW_FOREIGN) pattern SDL_WINDOW_ALLOW_HIGHDPI = (#const SDL_WINDOW_ALLOW_HIGHDPI)+pattern SDL_WINDOW_MOUSE_CAPTURE = (#const SDL_WINDOW_MOUSE_CAPTURE)+pattern SDL_WINDOW_VULKAN = (#const SDL_WINDOW_VULKAN) pattern SDL_WINDOWPOS_UNDEFINED = (#const SDL_WINDOWPOS_UNDEFINED) pattern SDL_WINDOWPOS_CENTERED = (#const SDL_WINDOWPOS_CENTERED)+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_0 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(0))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_1 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(1))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_2 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(2))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_3 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(3))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_4 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(4))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_5 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(5))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_6 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(6))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_7 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(7))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_8 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(8))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_9 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(9))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_10 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(10))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_11 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(11))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_12 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(12))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_13 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(13))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_14 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(14))+pattern SDL_WINDOWPOS_CENTERED_DISPLAY_15 = (#const SDL_WINDOWPOS_CENTERED_DISPLAY(15)) pattern SDL_HAPTIC_CONSTANT = (#const SDL_HAPTIC_CONSTANT)
src/SDL/Raw/Event.hs view
@@ -46,12 +46,14 @@ stopTextInput, -- * Mouse Support+ captureMouse, createColorCursor, createCursor, createSystemCursor, freeCursor, getCursor, getDefaultCursor,+ getGlobalMouseState, getMouseFocus, getMouseState, getRelativeMouseMode,@@ -59,11 +61,14 @@ setCursor, setRelativeMouseMode, showCursor,+ warpMouseGlobal, warpMouseInWindow, -- * Joystick Support joystickClose,+ joystickCurrentPowerLevel, joystickEventState,+ joystickFromInstanceID, joystickGetAttached, joystickGetAxis, joystickGetBall,@@ -90,6 +95,8 @@ gameControllerAddMappingsFromRW, gameControllerClose, gameControllerEventState,+ gameControllerFromInstanceID,+ gameControllerFromPlayerIndex, gameControllerGetAttached, gameControllerGetAxis, gameControllerGetAxisFromString,@@ -98,6 +105,12 @@ gameControllerGetButton, gameControllerGetButtonFromString, gameControllerGetJoystick,+ gameControllerGetNumTouchpadFingers,+ gameControllerGetNumTouchpads,+ gameControllerGetPlayerIndex,+ gameControllerHasLED,+ gameControllerHasRumble,+ gameControllerHasRumbleTriggers, gameControllerGetStringForAxis, gameControllerGetStringForButton, gameControllerMapping,@@ -106,7 +119,13 @@ gameControllerNameForIndex, gameControllerOpen, gameControllerUpdate,- isGameController+ gameControllerRumble,+ gameControllerRumbleTriggers,+ gameControllerSetLED,+ gameControllerSetPlayerIndex,+ isGameController,+ eventBuffer,+ eventBufferSize ) where import Control.Monad.IO.Class@@ -164,12 +183,14 @@ foreign import ccall "SDL.h SDL_StartTextInput" startTextInputFFI :: IO () foreign import ccall "SDL.h SDL_StopTextInput" stopTextInputFFI :: IO () +foreign import ccall "SDL.h SDL_CaptureMouse" captureMouseFFI :: Bool -> IO CInt foreign import ccall "SDL.h SDL_CreateColorCursor" createColorCursorFFI :: Ptr Surface -> CInt -> CInt -> IO Cursor foreign import ccall "SDL.h SDL_CreateCursor" createCursorFFI :: Ptr Word8 -> Ptr Word8 -> CInt -> CInt -> CInt -> CInt -> IO Cursor foreign import ccall "SDL.h SDL_CreateSystemCursor" createSystemCursorFFI :: SystemCursor -> IO Cursor foreign import ccall "SDL.h SDL_FreeCursor" freeCursorFFI :: Cursor -> IO () foreign import ccall "SDL.h SDL_GetCursor" getCursorFFI :: IO Cursor foreign import ccall "SDL.h SDL_GetDefaultCursor" getDefaultCursorFFI :: IO Cursor+foreign import ccall "SDL.h SDL_GetGlobalMouseState" getGlobalMouseStateFFI :: Ptr CInt -> Ptr CInt -> IO Word32 foreign import ccall "SDL.h SDL_GetMouseFocus" getMouseFocusFFI :: IO Window foreign import ccall "SDL.h SDL_GetMouseState" getMouseStateFFI :: Ptr CInt -> Ptr CInt -> IO Word32 foreign import ccall "SDL.h SDL_GetRelativeMouseMode" getRelativeMouseModeFFI :: IO Bool@@ -177,10 +198,13 @@ foreign import ccall "SDL.h SDL_SetCursor" setCursorFFI :: Cursor -> IO () foreign import ccall "SDL.h SDL_SetRelativeMouseMode" setRelativeMouseModeFFI :: Bool -> IO CInt foreign import ccall "SDL.h SDL_ShowCursor" showCursorFFI :: CInt -> IO CInt+foreign import ccall "SDL.h SDL_WarpMouseGlobal" warpMouseGlobalFFI :: CInt -> CInt -> IO CInt foreign import ccall "SDL.h SDL_WarpMouseInWindow" warpMouseInWindowFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_JoystickClose" joystickCloseFFI :: Joystick -> IO ()+foreign import ccall "SDL.h SDL_JoystickCurrentPowerLevel" joystickCurrentPowerLevelFFI :: Joystick -> IO JoystickPowerLevel foreign import ccall "SDL.h SDL_JoystickEventState" joystickEventStateFFI :: CInt -> IO CInt+foreign import ccall "SDL.h SDL_JoystickFromInstanceID" joystickFromInstanceIDFFI :: JoystickID -> IO Joystick foreign import ccall "SDL.h SDL_JoystickGetAttached" joystickGetAttachedFFI :: Joystick -> IO Bool foreign import ccall "SDL.h SDL_JoystickGetAxis" joystickGetAxisFFI :: Joystick -> CInt -> IO Int16 foreign import ccall "SDL.h SDL_JoystickGetBall" joystickGetBallFFI :: Joystick -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt@@ -205,6 +229,8 @@ foreign import ccall "SDL.h SDL_GameControllerAddMappingsFromRW" gameControllerAddMappingsFromRWFFI :: Ptr RWops -> CInt -> IO CInt foreign import ccall "SDL.h SDL_GameControllerClose" gameControllerCloseFFI :: GameController -> IO () foreign import ccall "SDL.h SDL_GameControllerEventState" gameControllerEventStateFFI :: CInt -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerFromInstanceID" gameControllerFromInstanceIDFFI :: JoystickID -> IO GameController+foreign import ccall "SDL.h SDL_GameControllerFromPlayerIndex" gameControllerFromPlayerIndexFFI :: CInt -> IO GameController foreign import ccall "SDL.h SDL_GameControllerGetAttached" gameControllerGetAttachedFFI :: GameController -> IO Bool foreign import ccall "SDL.h SDL_GameControllerGetAxis" gameControllerGetAxisFFI :: GameController -> GameControllerAxis -> IO Int16 foreign import ccall "SDL.h SDL_GameControllerGetAxisFromString" gameControllerGetAxisFromStringFFI :: CString -> IO GameControllerAxis@@ -213,6 +239,12 @@ foreign import ccall "SDL.h SDL_GameControllerGetButton" gameControllerGetButtonFFI :: GameController -> GameControllerButton -> IO Word8 foreign import ccall "SDL.h SDL_GameControllerGetButtonFromString" gameControllerGetButtonFromStringFFI :: CString -> IO GameControllerButton foreign import ccall "SDL.h SDL_GameControllerGetJoystick" gameControllerGetJoystickFFI :: GameController -> IO Joystick+foreign import ccall "SDL.h SDL_GameControllerGetNumTouchpadFingers" gameControllerGetNumTouchpadFingersFFI :: GameController -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerGetNumTouchpads" gameControllerGetNumTouchpadsFFI :: GameController -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerGetPlayerIndex" gameControllerGetPlayerIndexFFI :: GameController -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerHasLED" gameControllerHasLEDFFI :: GameController -> IO Bool+foreign import ccall "SDL.h SDL_GameControllerHasRumble" gameControllerHasRumbleFFI :: GameController -> IO Bool+foreign import ccall "SDL.h SDL_GameControllerHasRumbleTriggers" gameControllerHasRumbleTriggersFFI :: GameController -> IO Bool foreign import ccall "SDL.h SDL_GameControllerGetStringForAxis" gameControllerGetStringForAxisFFI :: GameControllerAxis -> IO CString foreign import ccall "SDL.h SDL_GameControllerGetStringForButton" gameControllerGetStringForButtonFFI :: GameControllerButton -> IO CString foreign import ccall "SDL.h SDL_GameControllerMapping" gameControllerMappingFFI :: GameController -> IO CString@@ -221,8 +253,15 @@ foreign import ccall "SDL.h SDL_GameControllerNameForIndex" gameControllerNameForIndexFFI :: CInt -> IO CString foreign import ccall "SDL.h SDL_GameControllerOpen" gameControllerOpenFFI :: CInt -> IO GameController foreign import ccall "SDL.h SDL_GameControllerUpdate" gameControllerUpdateFFI :: IO ()+foreign import ccall "SDL.h SDL_GameControllerRumble" gameControllerRumbleFFI :: GameController -> CUShort -> CUShort -> CUInt -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerRumbleTriggers" gameControllerRumbleTriggersFFI :: GameController -> CUShort -> CUShort -> CUInt -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerSetLED" gameControllerSetLEDFFI :: GameController -> Word8 -> Word8 -> Word8 -> IO CInt+foreign import ccall "SDL.h SDL_GameControllerSetPlayerIndex" gameControllerSetPlayerIndexFFI :: GameController -> CInt -> IO () foreign import ccall "SDL.h SDL_IsGameController" isGameControllerFFI :: CInt -> IO Bool +foreign import ccall "sdlhelper.c SDLHelper_GetEventBufferSize" eventBufferSize :: CInt+foreign import ccall "sdlhelper.c SDLHelper_GetEventBuffer" eventBuffer :: Ptr Event+ addEventWatch :: MonadIO m => EventFilter -> Ptr () -> m () addEventWatch v1 v2 = liftIO $ addEventWatchFFI v1 v2 {-# INLINE addEventWatch #-}@@ -394,6 +433,10 @@ stopTextInput = liftIO stopTextInputFFI {-# INLINE stopTextInput #-} +captureMouse :: MonadIO m => Bool -> m CInt+captureMouse v1 = liftIO $ captureMouseFFI v1+{-# INLINE captureMouse #-}+ createColorCursor :: MonadIO m => Ptr Surface -> CInt -> CInt -> m Cursor createColorCursor v1 v2 v3 = liftIO $ createColorCursorFFI v1 v2 v3 {-# INLINE createColorCursor #-}@@ -418,6 +461,10 @@ getDefaultCursor = liftIO getDefaultCursorFFI {-# INLINE getDefaultCursor #-} +getGlobalMouseState :: MonadIO m => Ptr CInt -> Ptr CInt -> m Word32+getGlobalMouseState v1 v2 = liftIO $ getGlobalMouseStateFFI v1 v2+{-# INLINE getGlobalMouseState #-}+ getMouseFocus :: MonadIO m => m Window getMouseFocus = liftIO getMouseFocusFFI {-# INLINE getMouseFocus #-}@@ -446,6 +493,10 @@ showCursor v1 = liftIO $ showCursorFFI v1 {-# INLINE showCursor #-} +warpMouseGlobal :: MonadIO m => CInt -> CInt -> m CInt+warpMouseGlobal v1 v2 = liftIO $ warpMouseGlobalFFI v1 v2+{-# INLINE warpMouseGlobal #-}+ warpMouseInWindow :: MonadIO m => Window -> CInt -> CInt -> m () warpMouseInWindow v1 v2 v3 = liftIO $ warpMouseInWindowFFI v1 v2 v3 {-# INLINE warpMouseInWindow #-}@@ -454,10 +505,18 @@ joystickClose v1 = liftIO $ joystickCloseFFI v1 {-# INLINE joystickClose #-} +joystickCurrentPowerLevel :: MonadIO m => Joystick -> m JoystickPowerLevel+joystickCurrentPowerLevel v1 = liftIO $ joystickCurrentPowerLevelFFI v1+{-# INLINE joystickCurrentPowerLevel #-}+ joystickEventState :: MonadIO m => CInt -> m CInt joystickEventState v1 = liftIO $ joystickEventStateFFI v1 {-# INLINE joystickEventState #-} +joystickFromInstanceID :: MonadIO m => JoystickID -> m Joystick+joystickFromInstanceID v1 = liftIO $ joystickFromInstanceIDFFI v1+{-# INLINE joystickFromInstanceID #-}+ joystickGetAttached :: MonadIO m => Joystick -> m Bool joystickGetAttached v1 = liftIO $ joystickGetAttachedFFI v1 {-# INLINE joystickGetAttached #-}@@ -564,6 +623,14 @@ gameControllerEventState v1 = liftIO $ gameControllerEventStateFFI v1 {-# INLINE gameControllerEventState #-} +gameControllerFromInstanceID :: MonadIO m => JoystickID -> m GameController+gameControllerFromInstanceID v1 = liftIO $ gameControllerFromInstanceIDFFI v1+{-# INLINE gameControllerFromInstanceID #-}++gameControllerFromPlayerIndex :: MonadIO m => CInt -> m GameController+gameControllerFromPlayerIndex v1 = liftIO $ gameControllerFromPlayerIndexFFI v1+{-# INLINE gameControllerFromPlayerIndex #-}+ gameControllerGetAttached :: MonadIO m => GameController -> m Bool gameControllerGetAttached v1 = liftIO $ gameControllerGetAttachedFFI v1 {-# INLINE gameControllerGetAttached #-}@@ -600,6 +667,31 @@ gameControllerGetJoystick v1 = liftIO $ gameControllerGetJoystickFFI v1 {-# INLINE gameControllerGetJoystick #-} +gameControllerGetNumTouchpadFingers :: MonadIO m => GameController -> CInt -> m CInt+gameControllerGetNumTouchpadFingers gamecontroller touchpad =+ liftIO $ gameControllerGetNumTouchpadFingersFFI gamecontroller touchpad+{-# INLINE gameControllerGetNumTouchpadFingers #-}++gameControllerGetNumTouchpads :: MonadIO m => GameController -> m CInt+gameControllerGetNumTouchpads gamecontroller = liftIO $ gameControllerGetNumTouchpadsFFI gamecontroller+{-# INLINE gameControllerGetNumTouchpads #-}++gameControllerGetPlayerIndex :: MonadIO m => GameController -> m CInt+gameControllerGetPlayerIndex gamecontroller = liftIO $ gameControllerGetPlayerIndexFFI gamecontroller+{-# INLINE gameControllerGetPlayerIndex #-}++gameControllerHasLED :: MonadIO m => GameController -> m Bool+gameControllerHasLED gamecontroller = liftIO $ gameControllerHasLEDFFI gamecontroller+{-# INLINE gameControllerHasLED #-}++gameControllerHasRumble :: MonadIO m => GameController -> m Bool+gameControllerHasRumble gamecontroller = liftIO $ gameControllerHasRumbleFFI gamecontroller+{-# INLINE gameControllerHasRumble #-}++gameControllerHasRumbleTriggers :: MonadIO m => GameController -> m Bool+gameControllerHasRumbleTriggers gamecontroller = liftIO $ gameControllerHasRumbleTriggersFFI gamecontroller+{-# INLINE gameControllerHasRumbleTriggers #-}+ gameControllerGetStringForAxis :: MonadIO m => GameControllerAxis -> m CString gameControllerGetStringForAxis v1 = liftIO $ gameControllerGetStringForAxisFFI v1 {-# INLINE gameControllerGetStringForAxis #-}@@ -633,6 +725,22 @@ gameControllerUpdate :: MonadIO m => m () gameControllerUpdate = liftIO gameControllerUpdateFFI {-# INLINE gameControllerUpdate #-}++gameControllerRumble :: MonadIO m => GameController -> CUShort -> CUShort -> CUInt -> m CInt+gameControllerRumble v1 v2 v3 v4 = liftIO $ gameControllerRumbleFFI v1 v2 v3 v4+{-# INLINE gameControllerRumble #-}++gameControllerRumbleTriggers :: MonadIO m => GameController -> CUShort -> CUShort -> CUInt -> m CInt+gameControllerRumbleTriggers gamecontroller v1 v2 v3 = liftIO $ gameControllerRumbleTriggersFFI gamecontroller v1 v2 v3+{-# INLINE gameControllerRumbleTriggers #-}++gameControllerSetLED :: MonadIO m => GameController -> Word8 -> Word8 -> Word8 -> m CInt+gameControllerSetLED gamecontroller v1 v2 v3 = liftIO $ gameControllerSetLEDFFI gamecontroller v1 v2 v3+{-# INLINE gameControllerSetLED #-}++gameControllerSetPlayerIndex :: MonadIO m => GameController -> CInt -> m ()+gameControllerSetPlayerIndex gamecontroller v1 = liftIO $ gameControllerSetPlayerIndexFFI gamecontroller v1+{-# INLINE gameControllerSetPlayerIndex #-} isGameController :: MonadIO m => CInt -> m Bool isGameController v1 = liftIO $ isGameControllerFFI v1
src/SDL/Raw/Timer.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module SDL.Raw.Timer ( -- * Timer Support addTimer,@@ -6,6 +8,10 @@ getPerformanceFrequency, getTicks, removeTimer++#ifdef RECENT_ISH+ , getTicks64+#endif ) where import Control.Monad.IO.Class@@ -21,6 +27,10 @@ foreign import ccall "SDL.h SDL_GetTicks" getTicksFFI :: IO Word32 foreign import ccall "SDL.h SDL_RemoveTimer" removeTimerFFI :: TimerID -> IO Bool +#ifdef RECENT_ISH+foreign import ccall "SDL.h SDL_GetTicks64" getTicks64FFI :: IO Word64+#endif+ addTimer :: MonadIO m => Word32 -> TimerCallback -> Ptr () -> m TimerID addTimer v1 v2 v3 = liftIO $ addTimerFFI v1 v2 v3 {-# INLINE addTimer #-}@@ -44,3 +54,9 @@ removeTimer :: MonadIO m => TimerID -> m Bool removeTimer v1 = liftIO $ removeTimerFFI v1 {-# INLINE removeTimer #-}++#ifdef RECENT_ISH+getTicks64 :: MonadIO m => m Word64+getTicks64 = liftIO getTicks64FFI+{-# INLINE getTicks64 #-}+#endif
src/SDL/Raw/Types.hsc view
@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+ module SDL.Raw.Types ( -- * Type Aliases -- ** Function Types+ VkGetInstanceProcAddrFunc,+ AudioCallback, EventFilter, HintCallback,@@ -40,6 +44,8 @@ TimerID, TLSID, TouchID,+ VkInstance,+ VkSurfaceKHR, Window, -- * Data Structures@@ -63,6 +69,11 @@ PixelFormat(..), Point(..), Rect(..),+#ifdef RECENT_ISH+ FPoint(..),+ FRect(..),+ Vertex(..),+#endif RendererInfo(..), RWops(..), Surface(..),@@ -81,6 +92,8 @@ import Foreign.Storable import SDL.Raw.Enum +type VkGetInstanceProcAddrFunc = VkInstance -> CString -> IO (FunPtr ())+ type AudioCallback = FunPtr (Ptr () -> Ptr Word8 -> CInt -> IO ()) type EventFilter = FunPtr (Ptr () -> Ptr Event -> IO CInt) type HintCallback = FunPtr (Ptr () -> CString -> CString -> CString -> IO ())@@ -140,6 +153,8 @@ type TimerID = CInt type TLSID = CUInt type TouchID = Int64+type VkInstance = Ptr ()+type VkSurfaceKHR = Word64 type Window = Ptr () data Atomic = Atomic@@ -148,7 +163,7 @@ instance Storable Atomic where sizeOf _ = (#size SDL_atomic_t)- alignment = sizeOf+ alignment _ = (#alignment SDL_atomic_t) peek ptr = do value <- (#peek SDL_atomic_t, value) ptr return $! Atomic value@@ -169,7 +184,7 @@ instance Storable AudioCVT where sizeOf _ = (#size SDL_AudioCVT)- alignment = sizeOf+ alignment _ = (#alignment SDL_AudioCVT) peek ptr = do needed <- (#peek SDL_AudioCVT, needed) ptr src_format <- (#peek SDL_AudioCVT, src_format) ptr@@ -205,7 +220,7 @@ instance Storable AudioSpec where sizeOf _ = (#size SDL_AudioSpec)- alignment = sizeOf+ alignment _ = (#alignment SDL_AudioSpec) peek ptr = do freq <- (#peek SDL_AudioSpec, freq) ptr format <- (#peek SDL_AudioSpec, format) ptr@@ -235,7 +250,7 @@ instance Storable Color where sizeOf _ = (#size SDL_Color)- alignment = sizeOf+ alignment _ = (#alignment SDL_Color) peek ptr = do r <- (#peek SDL_Color, r) ptr g <- (#peek SDL_Color, g) ptr@@ -258,7 +273,7 @@ instance Storable DisplayMode where sizeOf _ = (#size SDL_DisplayMode)- alignment = sizeOf+ alignment _ = (#alignment SDL_DisplayMode) peek ptr = do format <- (#peek SDL_DisplayMode, format) ptr w <- (#peek SDL_DisplayMode, w) ptr@@ -304,6 +319,10 @@ , textInputEventWindowID :: !Word32 , textInputEventText :: ![CChar] }+ | KeymapChangedEvent+ { eventType :: !Word32+ , eventTimestamp :: !Word32+ } | MouseMotionEvent { eventType :: !Word32 , eventTimestamp :: !Word32@@ -333,6 +352,7 @@ , mouseWheelEventWhich :: !Word32 , mouseWheelEventX :: !Int32 , mouseWheelEventY :: !Int32+ , mouseWheelEventDirection :: !Word32 } | JoyAxisEvent { eventType :: !Word32@@ -387,6 +407,12 @@ , eventTimestamp :: !Word32 , controllerDeviceEventWhich :: !Int32 }+ | AudioDeviceEvent+ { eventType :: !Word32+ , eventTimestamp :: !Word32+ , audioDeviceEventWhich :: !Word32+ , audioDeviceEventIsCapture :: !Word8+ } | QuitEvent { eventType :: !Word32 , eventTimestamp :: !Word32@@ -452,7 +478,7 @@ instance Storable Event where sizeOf _ = (#size SDL_Event)- alignment = sizeOf+ alignment _ = (#alignment SDL_Event) peek ptr = do typ <- (#peek SDL_Event, common.type) ptr timestamp <- (#peek SDL_Event, common.timestamp) ptr@@ -482,6 +508,8 @@ text <- peekArray (#const SDL_TEXTINPUTEVENT_TEXT_SIZE) $ (#ptr SDL_Event, text.text) ptr let upToNull = takeWhile (/= 0) text return $! TextInputEvent typ timestamp wid upToNull+ (#const SDL_KEYMAPCHANGED) ->+ return $! KeymapChangedEvent typ timestamp (#const SDL_MOUSEMOTION) -> do wid <- (#peek SDL_Event, motion.windowID) ptr which <- (#peek SDL_Event, motion.which) ptr@@ -498,7 +526,8 @@ which <- (#peek SDL_Event, wheel.which) ptr x <- (#peek SDL_Event, wheel.x) ptr y <- (#peek SDL_Event, wheel.y) ptr- return $! MouseWheelEvent typ timestamp wid which x y+ direction <- (#peek SDL_Event, wheel.direction) ptr+ return $! MouseWheelEvent typ timestamp wid which x y direction (#const SDL_JOYAXISMOTION) -> do which <- (#peek SDL_Event, jaxis.which) ptr axis <- (#peek SDL_Event, jaxis.axis) ptr@@ -523,12 +552,14 @@ which <- (#peek SDL_Event, caxis.which) ptr axis <- (#peek SDL_Event, caxis.axis) ptr value <- (#peek SDL_Event, caxis.value) ptr- return $! ControllerButtonEvent typ timestamp which axis value+ return $! ControllerAxisEvent typ timestamp which axis value (#const SDL_CONTROLLERBUTTONDOWN) -> controllerbutton $ ControllerButtonEvent typ timestamp (#const SDL_CONTROLLERBUTTONUP) -> controllerbutton $ ControllerButtonEvent typ timestamp (#const SDL_CONTROLLERDEVICEADDED) -> controllerdevice $ ControllerDeviceEvent typ timestamp (#const SDL_CONTROLLERDEVICEREMOVED) -> controllerdevice $ ControllerDeviceEvent typ timestamp (#const SDL_CONTROLLERDEVICEREMAPPED) -> controllerdevice $ ControllerDeviceEvent typ timestamp+ (#const SDL_AUDIODEVICEADDED) -> audiodevice $ AudioDeviceEvent typ timestamp+ (#const SDL_AUDIODEVICEREMOVED) -> audiodevice $ AudioDeviceEvent typ timestamp (#const SDL_FINGERDOWN) -> finger $ TouchFingerEvent typ timestamp (#const SDL_FINGERUP) -> finger $ TouchFingerEvent typ timestamp (#const SDL_FINGERMOTION) -> finger $ TouchFingerEvent typ timestamp@@ -592,6 +623,11 @@ which <- (#peek SDL_Event, cdevice.which) ptr return $! f which + audiodevice f = do+ which <- (#peek SDL_Event, adevice.which) ptr+ iscapture <- (#peek SDL_Event, adevice.iscapture) ptr+ return $! f which iscapture+ finger f = do touchId <- (#peek SDL_Event, tfinger.touchId) ptr fingerId <- (#peek SDL_Event, tfinger.fingerId) ptr@@ -637,6 +673,9 @@ (#poke SDL_Event, common.timestamp) ptr timestamp (#poke SDL_Event, text.windowID) ptr wid pokeArray ((#ptr SDL_Event, text.text) ptr) text+ KeymapChangedEvent typ timestamp -> do+ (#poke SDL_Event, common.type) ptr typ+ (#poke SDL_Event, common.timestamp) ptr timestamp MouseMotionEvent typ timestamp wid which state x y xrel yrel -> do (#poke SDL_Event, common.type) ptr typ (#poke SDL_Event, common.timestamp) ptr timestamp@@ -657,13 +696,14 @@ (#poke SDL_Event, button.clicks) ptr clicks (#poke SDL_Event, button.x) ptr x (#poke SDL_Event, button.y) ptr y- MouseWheelEvent typ timestamp wid which x y -> do+ MouseWheelEvent typ timestamp wid which x y direction -> do (#poke SDL_Event, common.type) ptr typ (#poke SDL_Event, common.timestamp) ptr timestamp (#poke SDL_Event, wheel.windowID) ptr wid (#poke SDL_Event, wheel.which) ptr which (#poke SDL_Event, wheel.x) ptr x (#poke SDL_Event, wheel.y) ptr y+ (#poke SDL_Event, wheel.direction) ptr direction JoyAxisEvent typ timestamp which axis value -> do (#poke SDL_Event, common.type) ptr typ (#poke SDL_Event, common.timestamp) ptr timestamp@@ -709,6 +749,11 @@ (#poke SDL_Event, common.type) ptr typ (#poke SDL_Event, common.timestamp) ptr timestamp (#poke SDL_Event, cdevice.which) ptr which+ AudioDeviceEvent typ timestamp which iscapture -> do+ (#poke SDL_Event, common.type) ptr typ+ (#poke SDL_Event, common.timestamp) ptr timestamp+ (#poke SDL_Event, adevice.which) ptr which+ (#poke SDL_Event, adevice.iscapture) ptr iscapture QuitEvent typ timestamp -> do (#poke SDL_Event, common.type) ptr typ (#poke SDL_Event, common.timestamp) ptr timestamp@@ -771,7 +816,7 @@ instance Storable Finger where sizeOf _ = (#size SDL_Finger)- alignment = sizeOf+ alignment _ = (#alignment SDL_Finger) peek ptr = do fingerId <- (#peek SDL_Finger, id) ptr x <- (#peek SDL_Finger, x) ptr@@ -800,7 +845,7 @@ instance Storable GameControllerButtonBind where sizeOf _ = (#size SDL_GameControllerButtonBind)- alignment = sizeOf+ alignment _ = (#alignment SDL_GameControllerButtonBind) peek ptr = do bind_type <- (#peek SDL_GameControllerButtonBind, bindType) ptr case bind_type :: (#type SDL_GameControllerBindType) of@@ -840,7 +885,7 @@ instance Storable HapticDirection where sizeOf _ = (#size SDL_HapticDirection)- alignment = sizeOf+ alignment _ = (#alignment SDL_HapticDirection) peek ptr = do typ <- (#peek SDL_HapticDirection, type) ptr x <- (#peek SDL_HapticDirection, dir[0]) ptr@@ -936,7 +981,7 @@ instance Storable HapticEffect where sizeOf _ = (#size SDL_HapticEffect)- alignment = sizeOf+ alignment _ = (#alignment SDL_HapticEffect) peek ptr = do typ <- (#peek SDL_HapticEffect, type) ptr case typ of@@ -1108,7 +1153,7 @@ instance Storable JoystickGUID where sizeOf _ = (#size SDL_JoystickGUID)- alignment = sizeOf+ alignment _ = (#alignment SDL_JoystickGUID) peek ptr = do guid <- peekArray 16 $ (#ptr SDL_JoystickGUID, data) ptr return $! JoystickGUID guid@@ -1123,7 +1168,7 @@ instance Storable Keysym where sizeOf _ = (#size SDL_Keysym)- alignment = sizeOf+ alignment _ = (#alignment SDL_Keysym) peek ptr = do scancode <- (#peek SDL_Keysym, scancode) ptr sym <- (#peek SDL_Keysym, sym) ptr@@ -1142,7 +1187,7 @@ instance Storable MessageBoxButtonData where sizeOf _ = (#size SDL_MessageBoxButtonData)- alignment = sizeOf+ alignment _ = (#alignment SDL_MessageBoxButtonData) peek ptr = do flags <- (#peek SDL_MessageBoxButtonData, flags) ptr buttonid <- (#peek SDL_MessageBoxButtonData, buttonid) ptr@@ -1161,7 +1206,7 @@ instance Storable MessageBoxColor where sizeOf _ = (#size SDL_MessageBoxColor)- alignment = sizeOf+ alignment _ = (#alignment SDL_MessageBoxColor) peek ptr = do r <- (#peek SDL_MessageBoxColor, r) ptr g <- (#peek SDL_MessageBoxColor, g) ptr@@ -1182,7 +1227,7 @@ instance Storable MessageBoxColorScheme where sizeOf _ = (#size SDL_MessageBoxColorScheme)- alignment = sizeOf+ alignment _ = (#alignment SDL_MessageBoxColorScheme) peek ptr = do background <- (#peek SDL_MessageBoxColorScheme, colors[SDL_MESSAGEBOX_COLOR_BACKGROUND]) ptr text <- (#peek SDL_MessageBoxColorScheme, colors[SDL_MESSAGEBOX_COLOR_TEXT]) ptr@@ -1209,7 +1254,7 @@ instance Storable MessageBoxData where sizeOf _ = (#size SDL_MessageBoxData)- alignment = sizeOf+ alignment _ = (#alignment SDL_MessageBoxData) peek ptr = do flags <- (#peek SDL_MessageBoxData, flags) ptr window <- (#peek SDL_MessageBoxData, window) ptr@@ -1235,7 +1280,7 @@ instance Storable Palette where sizeOf _ = (#size SDL_Palette)- alignment = sizeOf+ alignment _ = (#alignment SDL_Palette) peek ptr = do ncolors <- (#peek SDL_Palette, ncolors) ptr colors <- (#peek SDL_Palette, colors) ptr@@ -1257,7 +1302,7 @@ instance Storable PixelFormat where sizeOf _ = (#size SDL_PixelFormat)- alignment = sizeOf+ alignment _ = (#alignment SDL_PixelFormat) peek ptr = do format <- (#peek SDL_PixelFormat, format) ptr palette <- (#peek SDL_PixelFormat, palette) ptr@@ -1285,7 +1330,7 @@ instance Storable Point where sizeOf _ = (#size SDL_Point)- alignment = sizeOf+ alignment _ = (#alignment SDL_Point) peek ptr = do x <- (#peek SDL_Point, x) ptr y <- (#peek SDL_Point, y) ptr@@ -1303,7 +1348,7 @@ instance Storable Rect where sizeOf _ = (#size SDL_Rect)- alignment = sizeOf+ alignment _ = (#alignment SDL_Rect) peek ptr = do x <- (#peek SDL_Rect, x) ptr y <- (#peek SDL_Rect, y) ptr@@ -1316,6 +1361,66 @@ (#poke SDL_Rect, w) ptr w (#poke SDL_Rect, h) ptr h +#ifdef RECENT_ISH++data FPoint = FPoint+ { fPointX :: !CFloat+ , fPointY :: !CFloat+ } deriving (Eq, Show, Typeable)++instance Storable FPoint where+ sizeOf _ = (#size SDL_FPoint)+ alignment _ = (#alignment SDL_FPoint)+ peek ptr = do+ x <- (#peek SDL_FPoint, x) ptr+ y <- (#peek SDL_FPoint, y) ptr+ return $! FPoint x y+ poke ptr (FPoint x y) = do+ (#poke SDL_FPoint, x) ptr x+ (#poke SDL_FPoint, y) ptr y++data FRect = FRect+ { fRectX :: !CFloat+ , fRectY :: !CFloat+ , fRectW :: !CFloat+ , fRectH :: !CFloat+ } deriving (Eq, Show, Typeable)++instance Storable FRect where+ sizeOf _ = (#size SDL_FRect)+ alignment _ = (#alignment SDL_FRect)+ peek ptr = do+ x <- (#peek SDL_FRect, x) ptr+ y <- (#peek SDL_FRect, y) ptr+ w <- (#peek SDL_FRect, w) ptr+ h <- (#peek SDL_FRect, h) ptr+ return $! FRect x y w h+ poke ptr (FRect x y w h) = do+ (#poke SDL_FRect, x) ptr x+ (#poke SDL_FRect, y) ptr y+ (#poke SDL_FRect, w) ptr w+ (#poke SDL_FRect, h) ptr h++data Vertex = Vertex+ { vertexPosition :: !FPoint+ , vertexColor :: !Color+ , vertexTexCoord :: !FPoint+ } deriving (Eq, Show, Typeable)++instance Storable Vertex where+ sizeOf _ = (#size SDL_Vertex)+ alignment _ = (#alignment SDL_Vertex)+ peek ptr = do+ position <- (#peek SDL_Vertex, position) ptr+ color <- (#peek SDL_Vertex, color) ptr+ tex_coord <- (#peek SDL_Vertex, tex_coord) ptr+ return $! Vertex position color tex_coord+ poke ptr (Vertex position color tex_coord) = do+ (#poke SDL_Vertex, position) ptr position+ (#poke SDL_Vertex, color) ptr color+ (#poke SDL_Vertex, tex_coord) ptr tex_coord+#endif+ data RendererInfo = RendererInfo { rendererInfoName :: !CString , rendererInfoFlags :: !Word32@@ -1327,7 +1432,7 @@ instance Storable RendererInfo where sizeOf _ = (#size SDL_RendererInfo)- alignment = sizeOf+ alignment _ = (#alignment SDL_RendererInfo) peek ptr = do name <- (#peek SDL_RendererInfo, name) ptr flags <- (#peek SDL_RendererInfo, flags) ptr@@ -1355,7 +1460,7 @@ instance Storable RWops where sizeOf _ = (#size SDL_RWops)- alignment = sizeOf+ alignment _ = (#alignment SDL_RWops) peek ptr = do size <- (#peek SDL_RWops, size) ptr seek <- (#peek SDL_RWops, seek) ptr@@ -1384,7 +1489,7 @@ instance Storable Surface where sizeOf _ = (#size SDL_Surface)- alignment = sizeOf+ alignment _ = (#alignment SDL_Surface) peek ptr = do format <- (#peek SDL_Surface, format) ptr w <- (#peek SDL_Surface, w) ptr@@ -1411,7 +1516,7 @@ instance Storable Version where sizeOf _ = (#size SDL_version)- alignment = sizeOf+ alignment _ = (#alignment SDL_version) peek ptr = do major <- (#peek SDL_version, major) ptr minor <- (#peek SDL_version, minor) ptr
src/SDL/Raw/Video.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module SDL.Raw.Video ( -- * Display and Window Management createWindow,@@ -29,12 +31,16 @@ getCurrentVideoDriver, getDesktopDisplayMode, getDisplayBounds,+ getDisplayDPI, getDisplayMode, getDisplayName,+ getDisplayUsableBounds,+ getGrabbedWindow, getNumDisplayModes, getNumVideoDisplays, getNumVideoDrivers, getVideoDriver,+ getWindowBordersSize, getWindowBrightness, getWindowData, getWindowDisplayIndex,@@ -46,6 +52,7 @@ getWindowID, getWindowMaximumSize, getWindowMinimumSize,+ getWindowOpacity, getWindowPixelFormat, getWindowPosition, getWindowSize,@@ -67,6 +74,7 @@ setWindowIcon, setWindowMaximumSize, setWindowMinimumSize,+ setWindowOpacity, setWindowPosition, setWindowSize, setWindowTitle,@@ -79,6 +87,7 @@ videoQuit, -- * 2D Accelerated Rendering+ composeCustomBlendMode, createRenderer, createSoftwareRenderer, createTexture,@@ -108,14 +117,34 @@ renderDrawRect, renderDrawRects, renderFillRect,+ renderFillRectEx, renderFillRects,+#ifdef RECENT_ISH+ renderCopyF,+ renderCopyExF,+ renderDrawLineF,+ renderDrawLinesF,+ renderDrawPointF,+ renderDrawPointsF,+ renderDrawRectF,+ renderDrawRectsF,+ renderFillRectF,+ renderFillRectsF,+ renderGeometry,+ renderGeometryRaw,+ getTextureScaleMode,+ setTextureScaleMode,+#endif renderGetClipRect,+ renderGetIntegerScale, renderGetLogicalSize, renderGetScale, renderGetViewport,+ renderIsClipEnabled, renderPresent, renderReadPixels, renderSetClipRect,+ renderSetIntegerScale, renderSetLogicalSize, renderSetScale, renderSetViewport,@@ -191,7 +220,15 @@ -- * Clipboard Handling getClipboardText, hasClipboardText,- setClipboardText+ setClipboardText,++ -- * Vulkan support functions+ vkLoadLibrary,+ vkGetVkGetInstanceProcAddr,+ vkUnloadLibrary,+ vkGetInstanceExtensions,+ vkCreateSurface,+ vkGetDrawableSize ) where import Control.Monad.IO.Class@@ -232,12 +269,16 @@ foreign import ccall "SDL.h SDL_GetCurrentVideoDriver" getCurrentVideoDriverFFI :: IO CString foreign import ccall "SDL.h SDL_GetDesktopDisplayMode" getDesktopDisplayModeFFI :: CInt -> Ptr DisplayMode -> IO CInt foreign import ccall "SDL.h SDL_GetDisplayBounds" getDisplayBoundsFFI :: CInt -> Ptr Rect -> IO CInt+foreign import ccall "SDL.h SDL_GetDisplayDPI" getDisplayDPIFFI :: CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO CInt foreign import ccall "SDL.h SDL_GetDisplayMode" getDisplayModeFFI :: CInt -> CInt -> Ptr DisplayMode -> IO CInt foreign import ccall "SDL.h SDL_GetDisplayName" getDisplayNameFFI :: CInt -> IO CString+foreign import ccall "SDL.h SDL_GetDisplayUsableBounds" getDisplayUsableBoundsFFI :: CInt -> Ptr Rect -> IO CInt+foreign import ccall "SDL.h SDL_GetGrabbedWindow" getGrabbedWindowFFI :: IO Window foreign import ccall "SDL.h SDL_GetNumDisplayModes" getNumDisplayModesFFI :: CInt -> IO CInt foreign import ccall "SDL.h SDL_GetNumVideoDisplays" getNumVideoDisplaysFFI :: IO CInt foreign import ccall "SDL.h SDL_GetNumVideoDrivers" getNumVideoDriversFFI :: IO CInt foreign import ccall "SDL.h SDL_GetVideoDriver" getVideoDriverFFI :: CInt -> IO CString+foreign import ccall "SDL.h SDL_GetWindowBordersSize" getWindowBordersSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CInt foreign import ccall "SDL.h SDL_GetWindowBrightness" getWindowBrightnessFFI :: Window -> IO CFloat foreign import ccall "SDL.h SDL_GetWindowData" getWindowDataFFI :: Window -> CString -> IO (Ptr ()) foreign import ccall "SDL.h SDL_GetWindowDisplayIndex" getWindowDisplayIndexFFI :: Window -> IO CInt@@ -249,6 +290,7 @@ foreign import ccall "SDL.h SDL_GetWindowID" getWindowIDFFI :: Window -> IO Word32 foreign import ccall "SDL.h SDL_GetWindowMaximumSize" getWindowMaximumSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO () foreign import ccall "SDL.h SDL_GetWindowMinimumSize" getWindowMinimumSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO ()+foreign import ccall "SDL.h SDL_GetWindowOpacity" getWindowOpacityFFI :: Window -> Ptr CFloat -> IO () foreign import ccall "SDL.h SDL_GetWindowPixelFormat" getWindowPixelFormatFFI :: Window -> IO Word32 foreign import ccall "SDL.h SDL_GetWindowPosition" getWindowPositionFFI :: Window -> Ptr CInt -> Ptr CInt -> IO () foreign import ccall "SDL.h SDL_GetWindowSize" getWindowSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO ()@@ -270,6 +312,7 @@ foreign import ccall "SDL.h SDL_SetWindowIcon" setWindowIconFFI :: Window -> Ptr Surface -> IO () foreign import ccall "SDL.h SDL_SetWindowMaximumSize" setWindowMaximumSizeFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_SetWindowMinimumSize" setWindowMinimumSizeFFI :: Window -> CInt -> CInt -> IO ()+foreign import ccall "SDL.h SDL_SetWindowOpacity" setWindowOpacityFFI :: Window -> CFloat -> IO () foreign import ccall "SDL.h SDL_SetWindowPosition" setWindowPositionFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_SetWindowSize" setWindowSizeFFI :: Window -> CInt -> CInt -> IO () foreign import ccall "SDL.h SDL_SetWindowTitle" setWindowTitleFFI :: Window -> CString -> IO ()@@ -281,6 +324,7 @@ foreign import ccall "SDL.h SDL_VideoInit" videoInitFFI :: CString -> IO CInt foreign import ccall "SDL.h SDL_VideoQuit" videoQuitFFI :: IO () +foreign import ccall "SDL.h SDL_ComposeCustomBlendMode" composeCustomBlendModeFFI :: BlendFactor -> BlendFactor -> BlendOperation -> BlendFactor -> BlendFactor -> BlendOperation -> IO BlendMode foreign import ccall "SDL.h SDL_CreateRenderer" createRendererFFI :: Window -> CInt -> Word32 -> IO Renderer foreign import ccall "SDL.h SDL_CreateSoftwareRenderer" createSoftwareRendererFFI :: Ptr Surface -> IO Renderer foreign import ccall "SDL.h SDL_CreateTexture" createTextureFFI :: Renderer -> Word32 -> CInt -> CInt -> CInt -> IO Texture@@ -310,14 +354,34 @@ foreign import ccall "SDL.h SDL_RenderDrawRect" renderDrawRectFFI :: Renderer -> Ptr Rect -> IO CInt foreign import ccall "SDL.h SDL_RenderDrawRects" renderDrawRectsFFI :: Renderer -> Ptr Rect -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderFillRect" renderFillRectFFI :: Renderer -> Ptr Rect -> IO CInt+#ifdef RECENT_ISH+foreign import ccall "SDL.h SDL_RenderCopyF" renderCopyFFFI :: Renderer -> Texture -> Ptr Rect -> Ptr FRect -> IO CInt+foreign import ccall "SDL.h SDL_RenderCopyExF" renderCopyExFFFI :: Renderer -> Texture -> Ptr Rect -> Ptr FRect -> CDouble -> Ptr FPoint -> RendererFlip -> IO CInt+foreign import ccall "SDL.h SDL_RenderDrawLineF" renderDrawLineFFFI :: Renderer -> CFloat -> CFloat -> CFloat -> CFloat -> IO CInt+foreign import ccall "SDL.h SDL_RenderDrawLinesF" renderDrawLinesFFFI :: Renderer -> Ptr FPoint -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_RenderDrawPointF" renderDrawPointFFFI :: Renderer -> CFloat -> CFloat -> IO CInt+foreign import ccall "SDL.h SDL_RenderDrawPointsF" renderDrawPointsFFFI :: Renderer -> Ptr FPoint -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_RenderDrawRectF" renderDrawRectFFFI :: Renderer -> Ptr FRect -> IO CInt+foreign import ccall "SDL.h SDL_RenderDrawRectsF" renderDrawRectsFFFI :: Renderer -> Ptr FRect -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_RenderFillRectF" renderFillRectFFFI :: Renderer -> Ptr FRect -> IO CInt+foreign import ccall "SDL.h SDL_RenderFillRectsF" renderFillRectsFFFI :: Renderer -> Ptr FRect -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_RenderGeometry" renderGeometryFFI :: Renderer -> Texture -> Ptr Vertex -> CInt -> Ptr CInt -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_RenderGeometryRaw" renderGeometryRawFFI :: Renderer -> Texture -> Ptr FPoint -> CInt -> Ptr Color -> CInt -> Ptr FPoint -> CInt -> CInt -> Ptr () -> CInt -> CInt -> IO CInt+foreign import ccall "SDL.h SDL_GetTextureScaleMode" getTextureScaleModeFFI :: Texture -> Ptr ScaleMode -> IO CInt+foreign import ccall "SDL.h SDL_SetTextureScaleMode" setTextureScaleModeFFI :: Texture -> ScaleMode -> IO CInt+#endif+foreign import ccall "sqlhelper.c SDLHelper_RenderFillRectEx" renderFillRectExFFI :: Renderer -> CInt -> CInt -> CInt -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderFillRects" renderFillRectsFFI :: Renderer -> Ptr Rect -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderGetClipRect" renderGetClipRectFFI :: Renderer -> Ptr Rect -> IO ()+foreign import ccall "SDL.h SDL_RenderGetIntegerScale" renderGetIntegerScaleFFI :: Renderer -> IO CInt foreign import ccall "SDL.h SDL_RenderGetLogicalSize" renderGetLogicalSizeFFI :: Renderer -> Ptr CInt -> Ptr CInt -> IO () foreign import ccall "SDL.h SDL_RenderGetScale" renderGetScaleFFI :: Renderer -> Ptr CFloat -> Ptr CFloat -> IO () foreign import ccall "SDL.h SDL_RenderGetViewport" renderGetViewportFFI :: Renderer -> Ptr Rect -> IO ()+foreign import ccall "SDL.h SDL_RenderIsClipEnabled" renderIsClipEnabledFFI :: Renderer -> IO Bool foreign import ccall "SDL.h SDL_RenderPresent" renderPresentFFI :: Renderer -> IO () foreign import ccall "SDL.h SDL_RenderReadPixels" renderReadPixelsFFI :: Renderer -> Ptr Rect -> Word32 -> Ptr () -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderSetClipRect" renderSetClipRectFFI :: Renderer -> Ptr Rect -> IO CInt+foreign import ccall "SDL.h SDL_RenderSetIntegerScale" renderSetIntegerScaleFFI :: Renderer -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderSetLogicalSize" renderSetLogicalSizeFFI :: Renderer -> CInt -> CInt -> IO CInt foreign import ccall "SDL.h SDL_RenderSetScale" renderSetScaleFFI :: Renderer -> CFloat -> CFloat -> IO CInt foreign import ccall "SDL.h SDL_RenderSetViewport" renderSetViewportFFI :: Renderer -> Ptr Rect -> IO CInt@@ -388,6 +452,13 @@ foreign import ccall "SDL.h SDL_HasClipboardText" hasClipboardTextFFI :: IO Bool foreign import ccall "SDL.h SDL_SetClipboardText" setClipboardTextFFI :: CString -> IO CInt +foreign import ccall "SDL_vulkan.h SDL_Vulkan_LoadLibrary" vkLoadLibraryFFI :: CString -> IO CInt+foreign import ccall "SDL_vulkan.h SDL_Vulkan_GetVkGetInstanceProcAddr" vkGetVkGetInstanceProcAddrFFI :: IO (FunPtr VkGetInstanceProcAddrFunc)+foreign import ccall "SDL_vulkan.h SDL_Vulkan_UnloadLibrary" vkUnloadLibraryFFI :: IO ()+foreign import ccall "SDL_vulkan.h SDL_Vulkan_GetInstanceExtensions" vkGetInstanceExtensionsFFI :: Window -> Ptr CUInt -> Ptr CString -> IO Bool+foreign import ccall "SDL_vulkan.h SDL_Vulkan_CreateSurface" vkCreateSurfaceFFI :: Window -> VkInstance -> Ptr VkSurfaceKHR -> IO Bool+foreign import ccall "SDL_vulkan.h SDL_Vulkan_GetDrawableSize" vkGetDrawableSizeFFI :: Window -> Ptr CInt -> Ptr CInt -> IO ()+ createWindow :: MonadIO m => CString -> CInt -> CInt -> CInt -> CInt -> Word32 -> m Window createWindow v1 v2 v3 v4 v5 v6 = liftIO $ createWindowFFI v1 v2 v3 v4 v5 v6 {-# INLINE createWindow #-}@@ -504,6 +575,10 @@ getDisplayBounds v1 v2 = liftIO $ getDisplayBoundsFFI v1 v2 {-# INLINE getDisplayBounds #-} +getDisplayDPI :: MonadIO m => CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> m CInt+getDisplayDPI v1 v2 v3 v4 = liftIO $ getDisplayDPIFFI v1 v2 v3 v4+{-# INLINE getDisplayDPI #-}+ getDisplayMode :: MonadIO m => CInt -> CInt -> Ptr DisplayMode -> m CInt getDisplayMode v1 v2 v3 = liftIO $ getDisplayModeFFI v1 v2 v3 {-# INLINE getDisplayMode #-}@@ -512,6 +587,14 @@ getDisplayName v1 = liftIO $ getDisplayNameFFI v1 {-# INLINE getDisplayName #-} +getDisplayUsableBounds :: MonadIO m => CInt -> Ptr Rect -> m CInt+getDisplayUsableBounds v1 v2 = liftIO $ getDisplayUsableBoundsFFI v1 v2+{-# INLINE getDisplayUsableBounds #-}++getGrabbedWindow :: MonadIO m => m Window+getGrabbedWindow = liftIO getGrabbedWindowFFI+{-# INLINE getGrabbedWindow #-}+ getNumDisplayModes :: MonadIO m => CInt -> m CInt getNumDisplayModes v1 = liftIO $ getNumDisplayModesFFI v1 {-# INLINE getNumDisplayModes #-}@@ -528,6 +611,10 @@ getVideoDriver v1 = liftIO $ getVideoDriverFFI v1 {-# INLINE getVideoDriver #-} +getWindowBordersSize :: MonadIO m => Window -> Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> m CInt+getWindowBordersSize v1 v2 v3 v4 v5 = liftIO $ getWindowBordersSizeFFI v1 v2 v3 v4 v5+{-# INLINE getWindowBordersSize #-}+ getWindowBrightness :: MonadIO m => Window -> m CFloat getWindowBrightness v1 = liftIO $ getWindowBrightnessFFI v1 {-# INLINE getWindowBrightness #-}@@ -572,6 +659,10 @@ getWindowMinimumSize v1 v2 v3 = liftIO $ getWindowMinimumSizeFFI v1 v2 v3 {-# INLINE getWindowMinimumSize #-} +getWindowOpacity :: MonadIO m => Window -> Ptr CFloat -> m ()+getWindowOpacity v1 v2 = liftIO $ getWindowOpacityFFI v1 v2+{-# INLINE getWindowOpacity #-}+ getWindowPixelFormat :: MonadIO m => Window -> m Word32 getWindowPixelFormat v1 = liftIO $ getWindowPixelFormatFFI v1 {-# INLINE getWindowPixelFormat #-}@@ -656,6 +747,10 @@ setWindowMinimumSize v1 v2 v3 = liftIO $ setWindowMinimumSizeFFI v1 v2 v3 {-# INLINE setWindowMinimumSize #-} +setWindowOpacity :: MonadIO m => Window -> CFloat -> m ()+setWindowOpacity v1 v2 = liftIO $ setWindowOpacityFFI v1 v2+{-# INLINE setWindowOpacity #-}+ setWindowPosition :: MonadIO m => Window -> CInt -> CInt -> m () setWindowPosition v1 v2 v3 = liftIO $ setWindowPositionFFI v1 v2 v3 {-# INLINE setWindowPosition #-}@@ -696,6 +791,10 @@ videoQuit = liftIO videoQuitFFI {-# INLINE videoQuit #-} +composeCustomBlendMode :: MonadIO m => BlendFactor -> BlendFactor -> BlendOperation -> BlendFactor -> BlendFactor -> BlendOperation -> m BlendMode+composeCustomBlendMode v1 v2 v3 v4 v5 v6 = liftIO $ composeCustomBlendModeFFI v1 v2 v3 v4 v5 v6+{-# INLINE composeCustomBlendMode #-}+ createRenderer :: MonadIO m => Window -> CInt -> Word32 -> m Renderer createRenderer v1 v2 v3 = liftIO $ createRendererFFI v1 v2 v3 {-# INLINE createRenderer #-}@@ -808,6 +907,10 @@ renderDrawRects v1 v2 v3 = liftIO $ renderDrawRectsFFI v1 v2 v3 {-# INLINE renderDrawRects #-} +renderFillRectEx :: MonadIO m => Renderer -> CInt -> CInt -> CInt -> CInt -> m CInt+renderFillRectEx v1 x y w h = liftIO $ renderFillRectExFFI v1 x y w h+{-# INLINE renderFillRectEx #-}+ renderFillRect :: MonadIO m => Renderer -> Ptr Rect -> m CInt renderFillRect v1 v2 = liftIO $ renderFillRectFFI v1 v2 {-# INLINE renderFillRect #-}@@ -816,10 +919,75 @@ renderFillRects v1 v2 v3 = liftIO $ renderFillRectsFFI v1 v2 v3 {-# INLINE renderFillRects #-} +#ifdef RECENT_ISH++renderCopyF :: MonadIO m => Renderer -> Texture -> Ptr Rect -> Ptr FRect -> m CInt+renderCopyF v1 v2 v3 v4 = liftIO $ renderCopyFFFI v1 v2 v3 v4+{-# INLINE renderCopyF #-}++renderCopyExF :: MonadIO m => Renderer -> Texture -> Ptr Rect -> Ptr FRect -> CDouble -> Ptr FPoint -> RendererFlip -> m CInt+renderCopyExF v1 v2 v3 v4 v5 v6 v7 = liftIO $ renderCopyExFFFI v1 v2 v3 v4 v5 v6 v7+{-# INLINE renderCopyExF #-}++renderDrawLineF :: MonadIO m => Renderer -> CFloat -> CFloat -> CFloat -> CFloat -> m CInt+renderDrawLineF v1 v2 v3 v4 v5 = liftIO $ renderDrawLineFFFI v1 v2 v3 v4 v5+{-# INLINE renderDrawLineF #-}++renderDrawLinesF :: MonadIO m => Renderer -> Ptr FPoint -> CInt -> m CInt+renderDrawLinesF v1 v2 v3 = liftIO $ renderDrawLinesFFFI v1 v2 v3+{-# INLINE renderDrawLinesF #-}++renderDrawPointF :: MonadIO m => Renderer -> CFloat -> CFloat -> m CInt+renderDrawPointF v1 v2 v3 = liftIO $ renderDrawPointFFFI v1 v2 v3+{-# INLINE renderDrawPointF #-}++renderDrawPointsF :: MonadIO m => Renderer -> Ptr FPoint -> CInt -> m CInt+renderDrawPointsF v1 v2 v3 = liftIO $ renderDrawPointsFFFI v1 v2 v3+{-# INLINE renderDrawPointsF #-}++renderDrawRectF :: MonadIO m => Renderer -> Ptr FRect -> m CInt+renderDrawRectF v1 v2 = liftIO $ renderDrawRectFFFI v1 v2+{-# INLINE renderDrawRectF #-}++renderDrawRectsF :: MonadIO m => Renderer -> Ptr FRect -> CInt -> m CInt+renderDrawRectsF v1 v2 v3 = liftIO $ renderDrawRectsFFFI v1 v2 v3+{-# INLINE renderDrawRectsF #-}++renderFillRectF :: MonadIO m => Renderer -> Ptr FRect -> m CInt+renderFillRectF v1 v2 = liftIO $ renderFillRectFFFI v1 v2+{-# INLINE renderFillRectF #-}++renderFillRectsF :: MonadIO m => Renderer -> Ptr FRect -> CInt -> m CInt+renderFillRectsF v1 v2 v3 = liftIO $ renderFillRectsFFFI v1 v2 v3+{-# INLINE renderFillRectsF #-}++renderGeometry :: MonadIO m => Renderer -> Texture -> Ptr Vertex -> CInt -> Ptr CInt -> CInt -> m CInt+renderGeometry v1 v2 v3 v4 v5 v6 = liftIO $ renderGeometryFFI v1 v2 v3 v4 v5 v6+{-# INLINE renderGeometry #-}++renderGeometryRaw :: MonadIO m => Renderer -> Texture -> Ptr FPoint -> CInt -> Ptr Color -> CInt -> Ptr FPoint -> CInt -> CInt -> Ptr () -> CInt -> CInt -> m CInt+renderGeometryRaw v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 = liftIO $ renderGeometryRawFFI v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12+{-# INLINE renderGeometryRaw #-}++getTextureScaleMode :: MonadIO m => Texture -> Ptr ScaleMode -> m CInt+getTextureScaleMode t ps = liftIO $ getTextureScaleModeFFI t ps+{-# INLINE getTextureScaleMode #-}++setTextureScaleMode :: MonadIO m => Texture -> ScaleMode -> m CInt+setTextureScaleMode t s = liftIO $ setTextureScaleModeFFI t s+{-# INLINE setTextureScaleMode #-}++#endif++ renderGetClipRect :: MonadIO m => Renderer -> Ptr Rect -> m () renderGetClipRect v1 v2 = liftIO $ renderGetClipRectFFI v1 v2 {-# INLINE renderGetClipRect #-} +renderGetIntegerScale :: MonadIO m => Renderer -> m CInt+renderGetIntegerScale v1 = liftIO $ renderGetIntegerScaleFFI v1+{-# INLINE renderGetIntegerScale #-}+ renderGetLogicalSize :: MonadIO m => Renderer -> Ptr CInt -> Ptr CInt -> m () renderGetLogicalSize v1 v2 v3 = liftIO $ renderGetLogicalSizeFFI v1 v2 v3 {-# INLINE renderGetLogicalSize #-}@@ -832,6 +1000,10 @@ renderGetViewport v1 v2 = liftIO $ renderGetViewportFFI v1 v2 {-# INLINE renderGetViewport #-} +renderIsClipEnabled :: MonadIO m => Renderer -> m Bool+renderIsClipEnabled v1 = liftIO $ renderIsClipEnabledFFI v1+{-# INLINE renderIsClipEnabled #-}+ renderPresent :: MonadIO m => Renderer -> m () renderPresent v1 = liftIO $ renderPresentFFI v1 {-# INLINE renderPresent #-}@@ -844,6 +1016,10 @@ renderSetClipRect v1 v2 = liftIO $ renderSetClipRectFFI v1 v2 {-# INLINE renderSetClipRect #-} +renderSetIntegerScale :: MonadIO m => Renderer -> CInt -> m CInt+renderSetIntegerScale v1 v2 = liftIO $ renderSetIntegerScaleFFI v1 v2+{-# INLINE renderSetIntegerScale #-}+ renderSetLogicalSize :: MonadIO m => Renderer -> CInt -> CInt -> m CInt renderSetLogicalSize v1 v2 v3 = liftIO $ renderSetLogicalSizeFFI v1 v2 v3 {-# INLINE renderSetLogicalSize #-}@@ -1111,3 +1287,27 @@ setClipboardText :: MonadIO m => CString -> m CInt setClipboardText v1 = liftIO $ setClipboardTextFFI v1 {-# INLINE setClipboardText #-}++vkLoadLibrary :: MonadIO m => CString -> m CInt+vkLoadLibrary v1 = liftIO $ vkLoadLibraryFFI v1+{-# INLINE vkLoadLibrary #-}++vkGetVkGetInstanceProcAddr :: MonadIO m => m (FunPtr VkGetInstanceProcAddrFunc)+vkGetVkGetInstanceProcAddr = liftIO vkGetVkGetInstanceProcAddrFFI+{-# INLINE vkGetVkGetInstanceProcAddr #-}++vkUnloadLibrary :: MonadIO m => m ()+vkUnloadLibrary = liftIO vkUnloadLibraryFFI+{-# INLINE vkUnloadLibrary #-}++vkGetInstanceExtensions :: MonadIO m => Window -> Ptr CUInt -> Ptr CString -> m Bool+vkGetInstanceExtensions v1 v2 v3 = liftIO $ vkGetInstanceExtensionsFFI v1 v2 v3+{-# INLINE vkGetInstanceExtensions #-}++vkCreateSurface :: MonadIO m => Window -> VkInstance -> Ptr VkSurfaceKHR -> m Bool+vkCreateSurface v1 v2 v3 = liftIO $ vkCreateSurfaceFFI v1 v2 v3+{-# INLINE vkCreateSurface #-}++vkGetDrawableSize :: MonadIO m => Window -> Ptr CInt -> Ptr CInt -> m ()+vkGetDrawableSize v1 v2 v3 = liftIO $ vkGetDrawableSizeFFI v1 v2 v3+{-# INLINE vkGetDrawableSize #-}
src/SDL/Time.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module SDL.Time ( -- * Time Measurement ticks@@ -13,6 +15,10 @@ , RetriggerTimer(..) , addTimer , removeTimer++#ifdef RECENT_ISH+ , ticks64+#endif ) where import Control.Monad.IO.Class (MonadIO, liftIO)@@ -22,20 +28,20 @@ import Foreign import GHC.Generics (Generic) -import SDL.Exception+import SDL.Internal.Exception import qualified SDL.Raw.Timer as Raw import qualified SDL.Raw.Types as Raw -- | Number of milliseconds since library initialization. ----- See @<https://wiki.libsdl.org/SDL_GetTicks SDL_GetTicks>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetTicks SDL_GetTicks>@ for C documentation. ticks :: MonadIO m => m Word32 ticks = Raw.getTicks -- | The current time in seconds since some arbitrary starting point (consist over the life of the application). ----- This time is derived from the system's performance counter - see @<https://wiki.libsdl.org/SDL_GetPerformanceFrequency SDL_GetPerformanceFrequency>@ and @<https://wiki.libsdl.org/SDL_GetPerformanceCounter SDL_GetPerformanceCounter>@ for C documentation about the implementation.+-- This time is derived from the system's performance counter - see @<https://wiki.libsdl.org/SDL2/SDL_GetPerformanceFrequency SDL_GetPerformanceFrequency>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetPerformanceCounter SDL_GetPerformanceCounter>@ for C documentation about the implementation. time :: (Fractional a, MonadIO m) => m a time = do freq <- Raw.getPerformanceFrequency@@ -46,7 +52,7 @@ -- -- Users are generally recommended to use 'threadDelay' instead, to take advantage of the abilities of the Haskell runtime. ----- See @<https://wiki.libsdl.org/SDL_Delay SDL_Delay>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_Delay SDL_Delay>@ for C documentation. delay :: MonadIO m => Word32 -> m () delay = Raw.delay @@ -67,7 +73,7 @@ -- | Set up a callback function to be run on a separate thread after the specified number of milliseconds has elapsed. ----- See @<https://wiki.libsdl.org/SDL_AddTimer SDL_AddTimer>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_AddTimer SDL_AddTimer>@ for C documentation. addTimer :: MonadIO m => Word32 -> TimerCallback -> m Timer addTimer timeout callback = liftIO $ do cb <- Raw.mkTimerCallback wrappedCb@@ -90,6 +96,14 @@ -- | Remove a 'Timer'. ----- See @<https://wiki.libsdl.org/SDL_RemoveTimer SDL_RemoveTimer>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RemoveTimer SDL_RemoveTimer>@ for C documentation. removeTimer :: MonadIO m => Timer -> m Bool removeTimer f = liftIO $ runTimerRemoval f++#ifdef RECENT_ISH+-- | Number of milliseconds since library initialization.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetTicks64 SDL_GetTicks64>@ for C documentation.+ticks64 :: MonadIO m => m Word64+ticks64 = Raw.getTicks64+#endif
src/SDL/Video.hs view
@@ -12,6 +12,7 @@ , createWindow , defaultWindow , WindowConfig(..)+ , WindowGraphicsContext(..) , WindowMode(..) , WindowPosition(..) , destroyWindow@@ -24,6 +25,7 @@ -- * Window Attributes , windowMinimumSize , windowMaximumSize+ , windowOpacity , windowSize , windowBordered , windowBrightness@@ -31,6 +33,8 @@ , windowGrab , setWindowMode , getWindowAbsolutePosition+ , getWindowBordersSize+ , setWindowIcon , setWindowPosition , windowTitle , windowData@@ -40,6 +44,7 @@ -- * Renderer Management , createRenderer+ , createSoftwareRenderer , destroyRenderer -- * Clipboard Handling@@ -61,9 +66,7 @@ -- -- Screen savers are disabled by default upon the initialization of the -- video subsystem.- , disableScreenSaver- , enableScreenSaver- , isScreenSaverEnabled+ , screenSaverEnabled -- * Message Box , showSimpleMessageBox@@ -80,7 +83,7 @@ import Data.Bits import Data.Data (Data) import Data.Foldable-import Data.Maybe (isJust, fromMaybe)+import Data.Maybe (fromMaybe) import Data.Monoid (First(..)) import Data.Text (Text) import Data.Typeable@@ -88,7 +91,7 @@ import Foreign.C import GHC.Generics (Generic) import SDL.Vect-import SDL.Exception+import SDL.Internal.Exception import SDL.Internal.Numbered import SDL.Internal.Types import SDL.Video.OpenGL@@ -104,9 +107,9 @@ -- Throws 'SDLException' on failure. createWindow :: MonadIO m => Text -> WindowConfig -> m Window createWindow title config = liftIO $ do- case windowOpenGL config of- Just glcfg -> setGLAttributes glcfg- Nothing -> return ()+ case windowGraphicsContext config of+ OpenGLContext glcfg -> setGLAttributes glcfg+ _ -> return () BS.useAsCString (Text.encodeUtf8 title) $ \title' -> do let create = Raw.createWindow title'@@ -121,10 +124,12 @@ , if windowHighDPI config then Raw.SDL_WINDOW_ALLOW_HIGHDPI else 0 , if windowInputGrabbed config then Raw.SDL_WINDOW_INPUT_GRABBED else 0 , toNumber $ windowMode config- , if isJust $ windowOpenGL config then Raw.SDL_WINDOW_OPENGL else 0+ , if ctxIsOpenGL (windowGraphicsContext config) then Raw.SDL_WINDOW_OPENGL else 0 , if windowResizable config then Raw.SDL_WINDOW_RESIZABLE else 0+ , if windowVisible config then 0 else Raw.SDL_WINDOW_HIDDEN+ , if windowGraphicsContext config == VulkanContext then Raw.SDL_WINDOW_VULKAN else 0 ]- setGLAttributes (OpenGLConfig (V4 r g b a) d s p) = do+ setGLAttributes (OpenGLConfig (V4 r g b a) d s ms p) = do let (msk, v0, v1, flg) = case p of Core Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) Core Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', 0)@@ -139,6 +144,8 @@ , (Raw.SDL_GL_ALPHA_SIZE, a) , (Raw.SDL_GL_DEPTH_SIZE, d) , (Raw.SDL_GL_STENCIL_SIZE, s)+ , (Raw.SDL_GL_MULTISAMPLEBUFFERS, if ms > 1 then 1 else 0)+ , (Raw.SDL_GL_MULTISAMPLESAMPLES, if ms > 1 then ms else 0) , (Raw.SDL_GL_CONTEXT_PROFILE_MASK, msk) , (Raw.SDL_GL_CONTEXT_MAJOR_VERSION, v0) , (Raw.SDL_GL_CONTEXT_MINOR_VERSION, v1)@@ -150,39 +157,59 @@ -- -- @ -- 'defaultWindow' = 'WindowConfig'--- { 'windowBorder' = True--- , 'windowHighDPI' = False--- , 'windowInputGrabbed' = False--- , 'windowMode' = 'Windowed'--- , 'windowOpenGL' = Nothing--- , 'windowPosition' = 'Wherever'--- , 'windowResizable' = False--- , 'windowInitialSize' = V2 800 600+-- { 'windowBorder' = True+-- , 'windowHighDPI' = False+-- , 'windowInputGrabbed' = False+-- , 'windowMode' = 'Windowed'+-- , 'windowGraphicsContext' = NoGraphicsContext+-- , 'windowPosition' = 'Wherever'+-- , 'windowResizable' = False+-- , 'windowInitialSize' = V2 800 600+-- , 'windowVisible' = True -- } -- @ defaultWindow :: WindowConfig defaultWindow = WindowConfig- { windowBorder = True- , windowHighDPI = False- , windowInputGrabbed = False- , windowMode = Windowed- , windowOpenGL = Nothing- , windowPosition = Wherever- , windowResizable = False- , windowInitialSize = V2 800 600+ { windowBorder = True+ , windowHighDPI = False+ , windowInputGrabbed = False+ , windowMode = Windowed+ , windowGraphicsContext = NoGraphicsContext+ , windowPosition = Wherever+ , windowResizable = False+ , windowInitialSize = V2 800 600+ , windowVisible = True } data WindowConfig = WindowConfig- { windowBorder :: Bool -- ^ Defaults to 'True'.- , windowHighDPI :: Bool -- ^ Defaults to 'False'. Can not be changed after window creation.- , windowInputGrabbed :: Bool -- ^ Defaults to 'False'. Whether the mouse shall be confined to the window.- , windowMode :: WindowMode -- ^ Defaults to 'Windowed'.- , windowOpenGL :: Maybe OpenGLConfig -- ^ Defaults to 'Nothing'. Can not be changed after window creation.- , windowPosition :: WindowPosition -- ^ Defaults to 'Wherever'.- , windowResizable :: Bool -- ^ Defaults to 'False'. Whether the window can be resized by the user. It is still possible to programatically change the size with 'setWindowSize'.- , windowInitialSize :: V2 CInt -- ^ Defaults to @(800, 600)@.+ { windowBorder :: Bool -- ^ Defaults to 'True'.+ , windowHighDPI :: Bool -- ^ Defaults to 'False'. Can not be changed after window creation.+ , windowInputGrabbed :: Bool -- ^ Defaults to 'False'. Whether the mouse shall be confined to the window.+ , windowMode :: WindowMode -- ^ Defaults to 'Windowed'.+ , windowGraphicsContext :: WindowGraphicsContext -- ^ Defaults to 'NoGraphicsContext'. Can not be changed after window creation.+ , windowPosition :: WindowPosition -- ^ Defaults to 'Wherever'.+ , windowResizable :: Bool -- ^ Defaults to 'False'. Whether the window can be resized by the user. It is still possible to programatically change the size by changing 'windowSize'.+ , windowInitialSize :: V2 CInt -- ^ Defaults to @(800, 600)@. If you set 'windowHighDPI' flag, window size in screen coordinates may differ from the size in pixels. Use 'glGetDrawableSize' or 'SDL.Video.Vulkan.vkGetDrawableSize' to get size in pixels.+ , windowVisible :: Bool -- ^ Defaults to 'True'. } deriving (Eq, Generic, Ord, Read, Show, Typeable) +-- | Configuration of additional graphics context that will be created for window.+--+-- Can not be changed after window creation.+data WindowGraphicsContext+ = NoGraphicsContext -- ^ Window will be created without any additional graphics context.+ | OpenGLContext OpenGLConfig -- ^ Window will be created with OpenGL support with parameters from 'OpenGLConfig'.+ | VulkanContext -- ^ Window will be created with Vulkan support.+ -- The following functions will be implicitly called by SDL C library:+ --+ -- 1. analogue of 'SDL.Video.Vulkan.vkLoadLibrary' 'Nothing' will be called automatically before first window creation;+ -- 2. analogue of 'SDL.Video.Vulkan.vkUnloadLibrary' will be called after last window destruction.+ deriving (Eq, Generic, Ord, Read, Show, Typeable)++ctxIsOpenGL :: WindowGraphicsContext -> Bool+ctxIsOpenGL (OpenGLContext _) = True+ctxIsOpenGL _ = False+ data WindowMode = Fullscreen -- ^ Real fullscreen with a video mode change | FullscreenDesktop -- ^ Fake fullscreen that takes the size of the desktop@@ -201,15 +228,15 @@ instance FromNumber WindowMode Word32 where fromNumber n = fromMaybe Windowed . getFirst $ foldMap First [- sdlWindowFullscreen- , sdlWindowFullscreenDesktop+ sdlWindowFullscreenDesktop+ , sdlWindowFullscreen , sdlWindowMaximized , sdlWindowMinimized ] where- maybeBit val msk = if n .&. msk > 0 then Just val else Nothing- sdlWindowFullscreen = maybeBit Fullscreen Raw.SDL_WINDOW_FULLSCREEN+ maybeBit val msk = if n .&. msk == msk then Just val else Nothing sdlWindowFullscreenDesktop = maybeBit FullscreenDesktop Raw.SDL_WINDOW_FULLSCREEN_DESKTOP+ sdlWindowFullscreen = maybeBit Fullscreen Raw.SDL_WINDOW_FULLSCREEN sdlWindowMaximized = maybeBit Maximized Raw.SDL_WINDOW_MAXIMIZED sdlWindowMinimized = maybeBit Minimized Raw.SDL_WINDOW_MINIMIZED @@ -265,12 +292,17 @@ setWindowMode (Window w) mode = liftIO . throwIfNot0_ "SDL.Video.setWindowMode" "SDL_SetWindowFullscreen" $ case mode of- Fullscreen -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN- FullscreenDesktop -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN_DESKTOP+ Fullscreen -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN <* Raw.raiseWindow w+ FullscreenDesktop -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN_DESKTOP <* Raw.raiseWindow w Maximized -> Raw.setWindowFullscreen w 0 <* Raw.maximizeWindow w Minimized -> Raw.minimizeWindow w >> return 0- Windowed -> Raw.restoreWindow w >> return 0+ Windowed -> Raw.setWindowFullscreen w 0 <* Raw.restoreWindow w +-- | Set the icon for a window.+setWindowIcon :: MonadIO m => Window -> Surface -> m ()+setWindowIcon (Window win) (Surface sfc _) =+ Raw.setWindowIcon win sfc+ -- | Set the position of the window. setWindowPosition :: MonadIO m => Window -> WindowPosition -> m () setWindowPosition (Window w) pos = case pos of@@ -287,11 +319,29 @@ Raw.getWindowPosition w wPtr hPtr V2 <$> peek wPtr <*> peek hPtr +-- | Get the size of a window's borders (decorations) around the client area (top, left, bottom, right).+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetWindowBordersSize SDL_GetWindowBordersSize>@ for C documentation.+getWindowBordersSize :: MonadIO m => Window -> m (Maybe (V4 CInt))+getWindowBordersSize (Window win) =+ liftIO $+ alloca $ \tPtr ->+ alloca $ \lPtr ->+ alloca $ \bPtr ->+ alloca $ \rPtr -> do+ n <- Raw.getWindowBordersSize win tPtr lPtr bPtr rPtr+ if n /= 0+ then return Nothing+ else fmap Just $ V4 <$> peek tPtr <*> peek lPtr <*> peek bPtr <*> peek rPtr+ -- | Get or set the size of a window's client area. Values beyond the maximum supported size are clamped. --+-- If window was created with 'windowHighDPI' flag, this size may differ from the size in pixels.+-- Use 'glGetDrawableSize' or 'SDL.Video.Vulkan.vkGetDrawableSize' to get size in pixels.+-- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetWindowSize SDL_SetWindowSize>@ and @<https://wiki.libsdl.org/SDL_GetWindowSize SDL_GetWindowSize>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetWindowSize SDL_SetWindowSize>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetWindowSize SDL_GetWindowSize>@ for C documentation. windowSize :: Window -> StateVar (V2 CInt) windowSize (Window win) = makeStateVar getWindowSize setWindowSize where@@ -308,7 +358,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetWindowTitle SDL_SetWindowTitle>@ and @<https://wiki.libsdl.org/SDL_GetWindowTitle SDL_GetWindowTitle>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetWindowTitle SDL_SetWindowTitle>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetWindowTitle SDL_GetWindowTitle>@ for C documentation. windowTitle :: Window -> StateVar Text windowTitle (Window w) = makeStateVar getWindowTitle setWindowTitle where@@ -324,8 +374,6 @@ -- window and name. -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'.------ See @<https://wiki.libsdl.org/SDL_SetWindowTitle SDL_SetWindowTitle>@ and @<https://wiki.libsdl.org/SDL_GetWindowTitle SDL_GetWindowTitle>@ for C documentation. windowData :: Window -> CString -> StateVar (Ptr ()) windowData (Window w) key = makeStateVar getWindowData setWindowData where@@ -334,7 +382,7 @@ -- | Retrieve the configuration of the given window. ----- Note that 'Nothing' will be returned instead of potential OpenGL parameters+-- Note that 'NoGraphicsContext' will be returned instead of potential OpenGL parameters -- used during the creation of the window. getWindowConfig :: MonadIO m => Window -> m WindowConfig getWindowConfig (Window w) = do@@ -344,15 +392,17 @@ wPos <- getWindowAbsolutePosition (Window w) return WindowConfig {- windowBorder = wFlags .&. Raw.SDL_WINDOW_BORDERLESS == 0- , windowHighDPI = wFlags .&. Raw.SDL_WINDOW_ALLOW_HIGHDPI > 0- , windowInputGrabbed = wFlags .&. Raw.SDL_WINDOW_INPUT_GRABBED > 0- , windowMode = fromNumber wFlags- -- Should we store the openGL config that was used to create the window?- , windowOpenGL = Nothing- , windowPosition = Absolute (P wPos)- , windowResizable = wFlags .&. Raw.SDL_WINDOW_RESIZABLE > 0- , windowInitialSize = wSize+ windowBorder = wFlags .&. Raw.SDL_WINDOW_BORDERLESS == 0+ , windowHighDPI = wFlags .&. Raw.SDL_WINDOW_ALLOW_HIGHDPI > 0+ , windowInputGrabbed = wFlags .&. Raw.SDL_WINDOW_INPUT_GRABBED > 0+ , windowMode = fromNumber wFlags+ -- Should we store the OpenGL config that was used to create the window?+ , windowGraphicsContext = if wFlags .&. Raw.SDL_WINDOW_VULKAN > 0+ then VulkanContext else NoGraphicsContext+ , windowPosition = Absolute (P wPos)+ , windowResizable = wFlags .&. Raw.SDL_WINDOW_RESIZABLE > 0+ , windowInitialSize = wSize+ , windowVisible = wFlags .&. Raw.SDL_WINDOW_SHOWN > 0 } -- | Get the pixel format that is used for the given window.@@ -382,37 +432,30 @@ -- | Hide a window. ----- See @<https://wiki.libsdl.org/SDL_HideWindow SDL_HideWindow>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_HideWindow SDL_HideWindow>@ for C documentation. hideWindow :: MonadIO m => Window -> m () hideWindow (Window w) = Raw.hideWindow w -- | Raise the window above other windows and set the input focus. ----- See @<https://wiki.libsdl.org/SDL_RaiseWindow SDL_RaiseWindow>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RaiseWindow SDL_RaiseWindow>@ for C documentation. raiseWindow :: MonadIO m => Window -> m () raiseWindow (Window w) = Raw.raiseWindow w --- | Prevent the screen from being blanked by a screen saver. If you disable the screensaver, it is automatically re-enabled when SDL quits.------ See @<https://wiki.libsdl.org/SDL_DisableScreenSaver SDL_DisableScreenSaver>@ for C documentation.-disableScreenSaver :: MonadIO m => m ()-disableScreenSaver = Raw.disableScreenSaver---- | Allow the screen to be blanked by a screen saver.+-- | Get or set whether to allow the screen to be blanked by a screen saver. ----- See @<https://wiki.libsdl.org/SDL_EnableScreenSaver SDL_EnableScreenSaver>@ for C documentation.-enableScreenSaver :: MonadIO m => m ()-enableScreenSaver = Raw.enableScreenSaver+-- Screen savers are re-enabled, if needed, when SDL quits.+screenSaverEnabled :: StateVar Bool+screenSaverEnabled = makeStateVar (isScreenSaverEnabled) (setScreenSaverEnabled)+ where+ isScreenSaverEnabled = Raw.isScreenSaverEnabled --- | Check whether screen savers are enabled .------ See @<https://wiki.libsdl.org/SDL_IsScreenSaverEnabled SDL_IsScreenSaverEnabled>@ for C documentation.-isScreenSaverEnabled :: MonadIO m => m Bool-isScreenSaverEnabled = Raw.isScreenSaverEnabled+ setScreenSaverEnabled True = Raw.enableScreenSaver+ setScreenSaverEnabled False = Raw.disableScreenSaver -- | Show a window. ----- See @<https://wiki.libsdl.org/SDL_ShowWindow SDL_ShowWindow>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_ShowWindow SDL_ShowWindow>@ for C documentation. showWindow :: MonadIO m => Window -> m () showWindow (Window w) = Raw.showWindow w @@ -539,7 +582,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetWindowMaximumSize SDL_SetWindowMaximumSize>@ and @<https://wiki.libsdl.org/SDL_GetWindowMaximumSize SDL_GetWindowMaximumSize>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetWindowMaximumSize SDL_SetWindowMaximumSize>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetWindowMaximumSize SDL_GetWindowMaximumSize>@ for C documentation. windowMaximumSize :: Window -> StateVar (V2 CInt) windowMaximumSize (Window win) = makeStateVar getWindowMaximumSize setWindowMaximumSize where@@ -556,7 +599,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetWindowMinimumSize SDL_SetWindowMinimumSize>@ and @<https://wiki.libsdl.org/SDL_GetWindowMinimumSize SDL_GetWindowMinimumSize>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetWindowMinimumSize SDL_SetWindowMinimumSize>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetWindowMinimumSize SDL_GetWindowMinimumSize>@ for C documentation. windowMinimumSize :: Window -> StateVar (V2 CInt) windowMinimumSize (Window win) = makeStateVar getWindowMinimumSize setWindowMinimumSize where@@ -569,11 +612,36 @@ Raw.getWindowMinimumSize win wptr hptr V2 <$> peek wptr <*> peek hptr +-- | Get or set the opacity of a window.+--+-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetWindowOpacity SDL_SetWindowOpacity>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetWindowOpacity SDL_GetWindowOpacity>@ for C documentation.+windowOpacity :: Window -> StateVar CFloat+windowOpacity (Window win) = makeStateVar getWindowOpacity setWindowOpacity+ where+ setWindowOpacity opacity = Raw.setWindowOpacity win opacity++ getWindowOpacity =+ liftIO $+ alloca $ \optr -> do+ Raw.getWindowOpacity win optr+ peek optr+ createRenderer :: MonadIO m => Window -> CInt -> RendererConfig -> m Renderer createRenderer (Window w) driver config = liftIO . fmap Renderer $ throwIfNull "SDL.Video.createRenderer" "SDL_CreateRenderer" $ Raw.createRenderer w driver (toNumber config)++-- | Create a 2D software rendering context for the given surface.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateSoftwareRenderer>@+createSoftwareRenderer :: MonadIO m => Surface -> m Renderer+createSoftwareRenderer (Surface ptr _) =+ liftIO . fmap Renderer $+ throwIfNull "SDL.Video.createSoftwareRenderer" "SDL_CreateSoftwareRenderer" $+ Raw.createSoftwareRenderer ptr destroyRenderer :: MonadIO m => Renderer -> m () destroyRenderer (Renderer r) = Raw.destroyRenderer r
src/SDL/Video/OpenGL.hs view
@@ -37,7 +37,7 @@ import Foreign.C.Types import GHC.Generics (Generic) import SDL.Vect-import SDL.Exception+import SDL.Internal.Exception import SDL.Internal.Numbered import SDL.Internal.Types import qualified SDL.Raw as Raw@@ -53,6 +53,7 @@ -- { 'glColorPrecision' = V4 8 8 8 0 -- , 'glDepthPrecision' = 24 -- , 'glStencilPrecision' = 8+-- , 'glMultisampleSamples' = 1 -- , 'glProfile' = 'Compatibility' 'Normal' 2 1 -- } -- @@@ -61,15 +62,17 @@ { glColorPrecision = V4 8 8 8 0 , glDepthPrecision = 24 , glStencilPrecision = 8+ , glMultisampleSamples = 1 , glProfile = Compatibility Normal 2 1 } -- | Configuration used when creating an OpenGL rendering context. data OpenGLConfig = OpenGLConfig- { glColorPrecision :: V4 CInt -- ^ Defaults to 'V4' @8 8 8 0@.- , glDepthPrecision :: CInt -- ^ Defaults to @24@.- , glStencilPrecision :: CInt -- ^ Defaults to @8@.- , glProfile :: Profile -- ^ Defaults to 'Compatibility' 'Normal' @2 1@.+ { glColorPrecision :: V4 CInt -- ^ Defaults to 'V4' @8 8 8 0@.+ , glDepthPrecision :: CInt -- ^ Defaults to @24@.+ , glStencilPrecision :: CInt -- ^ Defaults to @8@.+ , glMultisampleSamples :: CInt -- ^ Defaults to @1@.+ , glProfile :: Profile -- ^ Defaults to 'Compatibility' 'Normal' @2 1@. } deriving (Eq, Generic, Ord, Read, Show, Typeable) -- | The profile a driver should use when creating an OpenGL context.@@ -100,7 +103,7 @@ -- Throws 'SDLException' if the window wasn't configured with OpenGL -- support, or if context creation fails. ----- See @<https://wiki.libsdl.org/SDL_GL_CreateContext SDL_GL_CreateContext>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_CreateContext SDL_GL_CreateContext>@ for C documentation. glCreateContext :: (Functor m, MonadIO m) => Window -> m GLContext glCreateContext (Window w) = GLContext <$> throwIfNull "SDL.Video.glCreateContext" "SDL_GL_CreateContext"@@ -110,7 +113,7 @@ -- -- Throws 'SDLException' on failure. ----- See @<https://wiki.libsdl.org/SDL_GL_MakeCurrent SDL_GL_MakeCurrent>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_MakeCurrent SDL_GL_MakeCurrent>@ for C documentation. glMakeCurrent :: (Functor m, MonadIO m) => Window -> GLContext -> m () glMakeCurrent (Window w) (GLContext ctx) = throwIfNeg_ "SDL.Video.OpenGL.glMakeCurrent" "SDL_GL_MakeCurrent" $@@ -125,7 +128,7 @@ -- The @glFinish@ command will block until the command queue has been fully -- processed. You should call that function before deleting a context. ----- See @<https://wiki.libsdl.org/SDL_GL_DeleteContext SDL_GL_DeleteContext>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_DeleteContext SDL_GL_DeleteContext>@ for C documentation. glDeleteContext :: MonadIO m => GLContext -> m () glDeleteContext (GLContext ctx) = Raw.glDeleteContext ctx @@ -133,7 +136,7 @@ -- contents of the back buffer are undefined, clear them with @glClear@ or -- equivalent before drawing to them again. ----- See @<https://wiki.libsdl.org/SDL_GL_SwapWindow SDL_GL_SwapWindow>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_SwapWindow SDL_GL_SwapWindow>@ for C documentation. glSwapWindow :: MonadIO m => Window -> m () glSwapWindow (Window w) = Raw.glSwapWindow w @@ -164,7 +167,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_GL_SetSwapInterval SDL_GL_SetSwapInterval>@ and @<https://wiki.libsdl.org/SDL_GL_GetSwapInterval SDL_GL_GetSwapInterval>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_SetSwapInterval SDL_GL_SetSwapInterval>@ and @<https://wiki.libsdl.org/SDL2/SDL_GL_GetSwapInterval SDL_GL_GetSwapInterval>@ for C documentation. swapInterval :: StateVar SwapInterval swapInterval = makeStateVar glGetSwapInterval glSetSwapInterval where@@ -176,6 +179,8 @@ -- | Get the size of a window's underlying drawable area in pixels (for use -- with glViewport).+--+-- It may differ from 'SDL.Video.windowSize' if window was created with 'SDL.Video.windowHighDPI' flag. glGetDrawableSize :: MonadIO m => Window -> m (V2 CInt) glGetDrawableSize (Window w) = liftIO $
src/SDL/Video/Renderer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}@@ -6,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-} -- | "SDL.Video.Renderer" provides a high-level interface to SDL's accelerated 2D rendering library. @@ -30,6 +32,21 @@ , drawRects , fillRect , fillRects+#ifdef RECENT_ISH+ , copyF+ , copyExF+ , drawLineF+ , drawLinesF+ , drawPointF+ , drawPointsF+ , drawRectF+ , drawRectsF+ , fillRectF+ , fillRectsF+ , renderGeometry+ , Raw.Vertex(..)+ , renderGeometryRaw+#endif , present -- * 'Renderer' State@@ -39,6 +56,7 @@ , rendererDrawColor , rendererRenderTarget , rendererClipRect+ , rendererIntegerScale , rendererLogicalSize , rendererScale , rendererViewport@@ -73,10 +91,12 @@ -- * 'Palette's and pixel formats , Palette+ , paletteNColors+ , paletteColors+ , paletteColor , PixelFormat(..)- , SurfacePixelFormat+ , SurfacePixelFormat(..) , formatPalette- , mapRGB , setPaletteColors , pixelFormatToMasks , masksToPixelFormat@@ -98,6 +118,10 @@ , textureBlendMode , BlendMode(..) , textureColorMod+#ifdef RECENT_ISH+ , textureScaleMode+ , ScaleMode(..)+#endif -- ** Accessing 'Texture' Data , lockTexture@@ -115,6 +139,7 @@ , getRenderDriverInfo ) where +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bits import Data.Data (Data)@@ -133,14 +158,17 @@ import GHC.Generics (Generic) import Prelude hiding (foldr) import SDL.Vect-import SDL.Exception+import SDL.Internal.Exception import SDL.Internal.Numbered import SDL.Internal.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI import qualified Data.Text.Encoding as Text+import qualified Data.Vector.Generic.Base as GV+import qualified Data.Vector.Generic.Mutable.Base as GMV import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as MSV+import qualified Data.Vector.Unboxed.Base as UV import qualified SDL.Raw as Raw #if !MIN_VERSION_base(4,8,0)@@ -150,22 +178,23 @@ -- | Perform a fast surface copy to a destination surface. ----- See @<https://wiki.libsdl.org/SDL_BlitSurface SDL_BlitSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_BlitSurface SDL_BlitSurface>@ for C documentation. surfaceBlit :: MonadIO m => Surface -- ^ The 'Surface' to be copied from -> Maybe (Rectangle CInt) -- ^ The rectangle to be copied, or 'Nothing' to copy the entire surface -> Surface -- ^ The 'Surface' that is the blit target -> Maybe (Point V2 CInt) -- ^ The position to blit to- -> m ()+ -> m (Maybe (Rectangle CInt)) surfaceBlit (Surface src _) srcRect (Surface dst _) dstLoc = liftIO $- throwIfNeg_ "SDL.Video.blitSurface" "SDL_BlitSurface" $ maybeWith with srcRect $ \srcPtr ->- maybeWith with (fmap (flip Rectangle 0) dstLoc) $ \dstPtr ->- Raw.blitSurface src (castPtr srcPtr) dst (castPtr dstPtr)+ maybeWith with (fmap (flip Rectangle 0) dstLoc) $ \dstPtr -> do+ _ <- throwIfNeg "SDL.Video.blitSurface" "SDL_BlitSurface" $+ Raw.blitSurface src (castPtr srcPtr) dst (castPtr dstPtr)+ maybe (pure Nothing) (\_ -> Just <$> peek dstPtr) dstLoc -- | Create a texture for a rendering context. ----- See @<https://wiki.libsdl.org/SDL_CreateTexture SDL_CreateTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateTexture SDL_CreateTexture>@ for C documentation. createTexture :: (Functor m,MonadIO m) => Renderer -- ^ The rendering context. -> PixelFormat@@ -179,7 +208,7 @@ -- | Create a texture from an existing surface. ----- See @<https://wiki.libsdl.org/SDL_CreateTextureFromSurface SDL_CreateTextureFromSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateTextureFromSurface SDL_CreateTextureFromSurface>@ for C documentation. createTextureFromSurface :: (Functor m,MonadIO m) => Renderer -- ^ The rendering context -> Surface -- ^ The surface containing pixel data used to fill the texture@@ -191,7 +220,7 @@ -- | Bind an OpenGL\/ES\/ES2 texture to the current context for use with when rendering OpenGL primitives directly. ----- See @<https://wiki.libsdl.org/SDL_GL_BindTexture SDL_GL_BindTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_BindTexture SDL_GL_BindTexture>@ for C documentation. glBindTexture :: (Functor m,MonadIO m) => Texture -- ^ The texture to bind to the current OpenGL\/ES\/ES2 context -> m ()@@ -201,7 +230,7 @@ -- | Unbind an OpenGL\/ES\/ES2 texture from the current context. ----- See @<https://wiki.libsdl.org/SDL_GL_UnbindTexture SDL_GL_UnbindTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GL_UnbindTexture SDL_GL_UnbindTexture>@ for C documentation. glUnbindTexture :: (Functor m,MonadIO m) => Texture -- ^ The texture to unbind from the current OpenGL\/ES\/ES2 context -> m ()@@ -211,30 +240,29 @@ -- | Updates texture rectangle with new pixel data. ----- See @<https://wiki.libsdl.org/SDL_UpdateTexture SDL_UpdateTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_UpdateTexture SDL_UpdateTexture>@ for C documentation. updateTexture :: (Functor m, MonadIO m) => Texture -- ^ The 'Texture' to be updated -> Maybe (Rectangle CInt) -- ^ The area to update, Nothing for entire texture -> BS.ByteString -- ^ The raw pixel data -> CInt -- ^ The number of bytes in a row of pixel data, including padding between lines- -> m Texture-updateTexture tex@(Texture t) rect pixels pitch = do+ -> m ()+updateTexture (Texture t) rect pixels pitch = do liftIO $ throwIfNeg_ "SDL.Video.updateTexture" "SDL_UpdateTexture" $ maybeWith with rect $ \rectPtr -> let (pixelForeign, _, _) = BSI.toForeignPtr pixels in withForeignPtr pixelForeign $ \pixelsPtr -> Raw.updateTexture t (castPtr rectPtr) (castPtr pixelsPtr) pitch- return tex -- | Destroy the specified texture. ----- See @<https://wiki.libsdl.org/SDL_DestroyTexture SDL_DestroyTexture>@ for the C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_DestroyTexture SDL_DestroyTexture>@ for the C documentation. destroyTexture :: MonadIO m => Texture -> m () destroyTexture (Texture t) = Raw.destroyTexture t -- | Lock a portion of the texture for *write-only* pixel access. ----- See @<https://wiki.libsdl.org/SDL_LockTexture SDL_LockTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_LockTexture SDL_LockTexture>@ for C documentation. lockTexture :: MonadIO m => Texture -- ^ The 'Texture' to lock for access, which must have been created with 'TextureAccessStreaming' -> Maybe (Rectangle CInt) -- ^ The area to lock for access; 'Nothing' to lock the entire texture@@ -253,21 +281,21 @@ -- -- /Warning/: See <https://bugzilla.libsdl.org/show_bug.cgi?id=1586 Bug No. 1586> before using this function! ----- See @<https://wiki.libsdl.org/SDL_UnlockTexture SDL_UnlockTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_UnlockTexture SDL_UnlockTexture>@ for C documentation. unlockTexture :: MonadIO m => Texture -> m ()-unlockTexture (Texture t) = liftIO $ Raw.unlockTexture t+unlockTexture (Texture t) = Raw.unlockTexture t -- | Set up a surface for directly accessing the pixels. ----- See @<https://wiki.libsdl.org/SDL_LockSurface SDL_LockSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_LockSurface SDL_LockSurface>@ for C documentation. lockSurface :: MonadIO m => Surface -> m ()-lockSurface (Surface s _) = liftIO $+lockSurface (Surface s _) = throwIfNeg_ "lockSurface" "SDL_LockSurface" $ Raw.lockSurface s -- | Release a surface after directly accessing the pixels. ----- See @<https://wiki.libsdl.org/SDL_UnlockSurface SDL_UnlockSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_UnlockSurface SDL_UnlockSurface>@ for C documentation. unlockSurface :: MonadIO m => Surface -> m () unlockSurface (Surface s _) = Raw.unlockSurface s @@ -307,7 +335,7 @@ -- | Query the attributes of a texture. ----- See @<https://wiki.libsdl.org/SDL_QueryTexture SDL_QueryTexture>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_QueryTexture SDL_QueryTexture>@ for C documentation. queryTexture :: MonadIO m => Texture -> m TextureInfo queryTexture (Texture tex) = liftIO $ alloca $ \pfPtr ->@@ -324,7 +352,7 @@ -- | Allocate a new RGB surface. ----- See @<https://wiki.libsdl.org/SDL_CreateRGBSurface SDL_CreateRGBSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateRGBSurface SDL_CreateRGBSurface>@ for C documentation. createRGBSurface :: (Functor m, MonadIO m) => V2 CInt -- ^ The size of the surface -> PixelFormat -- ^ The bit depth, red, green, blue and alpha mask for the pixels@@ -337,7 +365,7 @@ -- | Allocate a new RGB surface with existing pixel data. ----- See @<https://wiki.libsdl.org/SDL_CreateRGBSurfaceFrom SDL_CreateRGBSurfaceFrom>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_CreateRGBSurfaceFrom SDL_CreateRGBSurfaceFrom>@ for C documentation. createRGBSurfaceFrom :: (Functor m, MonadIO m) => MSV.IOVector Word8 -- ^ The existing pixel data -> V2 CInt -- ^ The size of the surface@@ -355,7 +383,7 @@ -- -- If there is a clip rectangle set on the destination (set via 'clipRect'), then this function will fill based on the intersection of the clip rectangle and the given 'Rectangle'. ----- See @<https://wiki.libsdl.org/SDL_FillRect SDL_FillRect>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_FillRect SDL_FillRect>@ for C documentation. surfaceFillRect :: MonadIO m => Surface -- ^ The 'Surface' that is the drawing target. -> Maybe (Rectangle CInt) -- ^ The rectangle to fill, or 'Nothing' to fill the entire surface.@@ -364,14 +392,14 @@ surfaceFillRect (Surface s _) rect (V4 r g b a) = liftIO $ throwIfNeg_ "SDL.Video.fillRect" "SDL_FillRect" $ maybeWith with rect $ \rectPtr -> do- format <- liftIO (Raw.surfaceFormat <$> peek s)+ format <- Raw.surfaceFormat <$> peek s Raw.mapRGBA format r g b a >>= Raw.fillRect s (castPtr rectPtr) -- | Perform a fast fill of a set of rectangles with a specific color. -- -- If there is a clip rectangle set on any of the destinations (set via 'clipRect'), then this function will fill based on the intersection of the clip rectangle and the given 'Rectangle's. ----- See @<https://wiki.libsdl.org/SDL_FillRect SDL_FillRects>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_FillRect SDL_FillRects>@ for C documentation. surfaceFillRects :: MonadIO m => Surface -- ^ The 'Surface' that is the drawing target. -> SV.Vector (Rectangle CInt) -- ^ A 'SV.Vector' of 'Rectangle's to be filled.@@ -380,7 +408,7 @@ surfaceFillRects (Surface s _) rects (V4 r g b a) = liftIO $ do throwIfNeg_ "SDL.Video.fillRects" "SDL_FillRects" $ SV.unsafeWith rects $ \rp -> do- format <- liftIO (Raw.surfaceFormat <$> peek s)+ format <- Raw.surfaceFormat <$> peek s Raw.fillRects s (castPtr rp) (fromIntegral (SV.length rects))@@ -390,13 +418,13 @@ -- -- If the surface was created using 'createRGBSurfaceFrom' then the pixel data is not freed. ----- See @<https://wiki.libsdl.org/SDL_FreeSurface SDL_FreeSurface>@ for the C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_FreeSurface SDL_FreeSurface>@ for the C documentation. freeSurface :: MonadIO m => Surface -> m () freeSurface (Surface s _) = Raw.freeSurface s -- | Load a surface from a BMP file. ----- See @<https://wiki.libsdl.org/SDL_LoadBMP SDL_LoadBMP>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_LoadBMP SDL_LoadBMP>@ for C documentation. loadBMP :: MonadIO m => FilePath -> m Surface loadBMP filePath = liftIO $ fmap unmanagedSurface $@@ -407,27 +435,6 @@ deriving (Eq, Typeable) -- It's possible we could use unsafePerformIO here, but I'm not--- sure. De need to guarantee that pointers aren't reused?--- | Map an RGB triple to an opaque pixel value for a given pixel format.------ This function maps the RGB color value to the specified pixel format and returns the pixel value best approximating the given RGB color value for the given pixel format.------ If the format has a palette (8-bit) the index of the closest matching color in the palette will be returned.------ If the specified pixel format has an alpha component it will be returned as all 1 bits (fully opaque).------ If the pixel format bpp (color depth) is less than 32-bpp then the unused upper bits of the return value can safely be ignored (e.g., with a 16-bpp format the return value can be assigned to a 'Word16', and similarly a 'Word8' for an 8-bpp format).------ See @<https://wiki.libsdl.org/SDL_MapRGB SDL_MapRGB>@ for C documentation.-mapRGB :: MonadIO m- => SurfacePixelFormat -- ^ The format of the pixel- -> V3 Word8 -- ^ The color to map- -> m Word32-mapRGB (SurfacePixelFormat fmt) (V3 r g b) = Raw.mapRGB fmt r g b--{-# DEPRECATED mapRGB "mapRGB is no longer needed, as it called implictly. If you still need this, use SDL.Raw.mapRGB" #-}---- It's possible we could use unsafePerformIO here, but I'm not -- sure. surface->{w,h} are immutable, but do we need to guarantee that pointers -- aren't reused by *different* surfaces. -- | Retrive the width and height of a 'Surface'.@@ -455,9 +462,30 @@ | p == nullPtr = Nothing | otherwise = Just (Palette p) +paletteNColors :: MonadIO m => Palette -> m CInt+paletteNColors (Palette p) = liftIO $ Raw.paletteNColors <$> peek p++paletteColors :: MonadIO m => Palette -> m (Maybe (SV.Vector (V4 Word8)))+paletteColors q@(Palette p) = do+ n <- liftIO $ fromIntegral <$> paletteNColors q+ let wrap p' | p' == nullPtr = Nothing+ | otherwise = return p'+ mv <- liftIO $ wrap . castPtr . Raw.paletteColors <$> peek p+ mColor <- liftIO $ traverse newForeignPtr_ mv+ return $ flip SV.unsafeFromForeignPtr0 n <$> mColor++paletteColor :: MonadIO m => Palette -> CInt -> m (Maybe (V4 Word8))+paletteColor q@(Palette p) i = do+ rp <- liftIO $ peek p+ m <- paletteNColors q+ if m > i && i >= 0 then+ liftIO $ fmap return . flip peekElemOff (fromIntegral i) . castPtr . Raw.paletteColors $ rp+ else+ return Nothing+ -- | Set a range of colors in a palette. ----- See @<https://wiki.libsdl.org/SDL_SetPaletteColors SDL_SetPaletteColors>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetPaletteColors SDL_SetPaletteColors>@ for C documentation. setPaletteColors :: MonadIO m => Palette -- ^ The 'Palette' to modify -> (SV.Vector (V4 Word8)) -- ^ A 'SV.Vector' of colours to copy into the palette@@ -472,7 +500,7 @@ -- | Get the SDL surface associated with the window. ----- See @<https://wiki.libsdl.org/SDL_GetWindowSurface SDL_GetWindowSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetWindowSurface SDL_GetWindowSurface>@ for C documentation. getWindowSurface :: (Functor m, MonadIO m) => Window -> m Surface getWindowSurface (Window w) = fmap unmanagedSurface $@@ -483,11 +511,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetRenderDrawBlendMode SDL_SetRenderDrawBlendMode>@ and @<https://wiki.libsdl.org/SDL_GetRenderDrawBlendMode SDL_GetRenderDrawBlendMode>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetRenderDrawBlendMode SDL_SetRenderDrawBlendMode>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetRenderDrawBlendMode SDL_GetRenderDrawBlendMode>@ for C documentation. rendererDrawBlendMode :: Renderer -> StateVar BlendMode rendererDrawBlendMode (Renderer r) = makeStateVar getRenderDrawBlendMode setRenderDrawBlendMode where- getRenderDrawBlendMode = liftIO $+ getRenderDrawBlendMode = alloca $ \bmPtr -> do throwIfNeg_ "SDL.Video.Renderer.getRenderDrawBlendMode" "SDL_GetRenderDrawBlendMode" $ Raw.getRenderDrawBlendMode r bmPtr@@ -501,11 +529,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetRenderDrawColor SDL_SetRenderDrawColor>@ and @<https://wiki.libsdl.org/SDL_GetRenderDrawColor SDL_GetRenderDrawColor>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetRenderDrawColor SDL_SetRenderDrawColor>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetRenderDrawColor SDL_GetRenderDrawColor>@ for C documentation. rendererDrawColor :: Renderer -> StateVar (V4 Word8) rendererDrawColor (Renderer re) = makeStateVar getRenderDrawColor setRenderDrawColor where- getRenderDrawColor = liftIO $+ getRenderDrawColor = alloca $ \r -> alloca $ \g -> alloca $ \b ->@@ -522,7 +550,7 @@ -- -- This is the function you use to reflect any changes to the surface on the screen. ----- See @<https://wiki.libsdl.org/SDL_UpdateWindowSurface SDL_UpdateWindowSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_UpdateWindowSurface SDL_UpdateWindowSurface>@ for C documentation. updateWindowSurface :: (Functor m, MonadIO m) => Window -> m () updateWindowSurface (Window w) = throwIfNeg_ "SDL.Video.updateWindowSurface" "SDL_UpdateWindowSurface" $@@ -574,7 +602,7 @@ instance Storable a => Storable (Rectangle a) where sizeOf ~(Rectangle o s) = sizeOf o + sizeOf s- alignment _ = 0+ alignment _ = alignment (undefined :: a) peek ptr = do o <- peek (castPtr ptr) s <- peek (castPtr (ptr `plusPtr` sizeOf o))@@ -583,6 +611,41 @@ poke (castPtr ptr) o poke (castPtr (ptr `plusPtr` sizeOf o)) s +newtype instance UV.MVector s (Rectangle a) = MV_Rectangle (UV.MVector s (Point V2 a, V2 a))+newtype instance UV.Vector (Rectangle a) = V_Rectangle (UV.Vector (Point V2 a, V2 a))++instance UV.Unbox a => GMV.MVector UV.MVector (Rectangle a) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ basicLength (MV_Rectangle v) = GMV.basicLength v+ basicUnsafeSlice m n (MV_Rectangle v) = MV_Rectangle (GMV.basicUnsafeSlice m n v)+ basicOverlaps (MV_Rectangle v) (MV_Rectangle u) = GMV.basicOverlaps v u+ basicUnsafeNew n = MV_Rectangle <$> GMV.basicUnsafeNew n+ basicUnsafeRead (MV_Rectangle v) i = uncurry Rectangle <$> GMV.basicUnsafeRead v i+ basicUnsafeWrite (MV_Rectangle v) i (Rectangle p e) = GMV.basicUnsafeWrite v i (p, e)+#if MIN_VERSION_vector(0,11,0)+ {-# INLINE basicInitialize #-}+ basicInitialize (MV_Rectangle v) = GMV.basicInitialize v+#endif++instance UV.Unbox a => GV.Vector UV.Vector (Rectangle a) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_Rectangle v) = V_Rectangle <$> GV.basicUnsafeFreeze v+ basicUnsafeThaw (V_Rectangle v) = MV_Rectangle <$> GV.basicUnsafeThaw v+ basicLength (V_Rectangle v) = GV.basicLength v+ basicUnsafeSlice m n (V_Rectangle v) = V_Rectangle (GV.basicUnsafeSlice m n v)+ basicUnsafeIndexM (V_Rectangle v) i = uncurry Rectangle <$> GV.basicUnsafeIndexM v i++instance UV.Unbox a => UV.Unbox (Rectangle a)+ data Surface = Surface (Ptr Raw.Surface) (Maybe (MSV.IOVector Word8)) deriving (Typeable) @@ -597,7 +660,7 @@ -- | Draw a rectangle outline on the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderDrawRect SDL_RenderDrawRect>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderDrawRect SDL_RenderDrawRect>@ for C documentation. drawRect :: MonadIO m => Renderer -> Maybe (Rectangle CInt) -- ^ The rectangle outline to draw. 'Nothing' for the entire rendering context.@@ -608,7 +671,7 @@ -- | Draw some number of rectangles on the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderDrawRects SDL_RenderDrawRects>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderDrawRects SDL_RenderDrawRects>@ for C documentation. drawRects :: MonadIO m => Renderer -> SV.Vector (Rectangle CInt) -> m () drawRects (Renderer r) rects = liftIO $ throwIfNeg_ "SDL.Video.drawRects" "SDL_RenderDrawRects" $@@ -619,20 +682,23 @@ -- | Fill a rectangle on the current rendering target with the drawing color. ----- See @<https://wiki.libsdl.org/SDL_RenderFillRect SDL_RenderFillRect>@ for C documentation.-fillRect :: MonadIO m- => Renderer- -> Maybe (Rectangle CInt) -- ^ The rectangle to fill. 'Nothing' for the entire rendering context.- -> m ()-fillRect (Renderer r) rect = liftIO $ do+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderFillRect SDL_RenderFillRect>@ for C documentation.+fillRect ::+ MonadIO m+ => Renderer+ -> Maybe (Rectangle CInt) -- ^ The rectangle to fill.+ -> m ()+fillRect (Renderer r) rect =+ liftIO $ throwIfNeg_ "SDL.Video.fillRect" "SDL_RenderFillRect" $- maybeWith with rect $ \rPtr ->- Raw.renderFillRect r- (castPtr rPtr)+ case rect of+ Nothing -> Raw.renderFillRect r nullPtr+ Just (Rectangle (P (V2 x y)) (V2 w h)) -> Raw.renderFillRectEx r x y w h+{-# INLINE fillRect #-} -- | Fill some number of rectangles on the current rendering target with the drawing color. ----- See @<https://wiki.libsdl.org/SDL_RenderFillRects SDL_RenderFillRects>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderFillRects SDL_RenderFillRects>@ for C documentation. fillRects :: MonadIO m => Renderer -> SV.Vector (Rectangle CInt) -> m () fillRects (Renderer r) rects = liftIO $ throwIfNeg_ "SDL.Video.fillRects" "SDL_RenderFillRects" $@@ -641,13 +707,141 @@ (castPtr rp) (fromIntegral (SV.length rects)) +#ifdef RECENT_ISH++-- | Copy a portion of the texture to the current rendering target.+copyF :: MonadIO m => Renderer -> Texture -> Maybe (Rectangle CInt) -> Maybe (Rectangle CFloat) -> m ()+copyF (Renderer r) (Texture t) srcRect dstRect = liftIO $+ throwIfNeg_ "SDL.Video.copyF" "SDL_RenderCopyF" $+ maybeWith with srcRect $ \src ->+ maybeWith with dstRect $ \dst ->+ Raw.renderCopyF r t (castPtr src) (castPtr dst)++-- | Copy a portion of the texture to the current rendering target, optionally rotating it by angle around the given center and also flipping it top-bottom and/or left-right.+copyExF :: MonadIO m+ => Renderer -- ^ The rendering context+ -> Texture -- ^ The source texture+ -> Maybe (Rectangle CInt) -- ^ The source rectangle to copy, or 'Nothing' for the whole texture+ -> Maybe (Rectangle CFloat) -- ^ The destination rectangle to copy to, or 'Nothing' for the whole rendering target. The texture will be stretched to fill the given rectangle.+ -> CDouble -- ^ The angle of rotation in degrees. The rotation will be performed clockwise.+ -> Maybe (Point V2 CFloat) -- ^ The point indicating the center of the rotation, or 'Nothing' to rotate around the center of the destination rectangle+ -> V2 Bool -- ^ Whether to flip the texture on the X and/or Y axis+ -> m ()+copyExF (Renderer r) (Texture t) srcRect dstRect theta center flips =+ liftIO $+ throwIfNeg_ "SDL.Video.copyExF" "SDL_RenderCopyExF" $+ maybeWith with srcRect $ \src ->+ maybeWith with dstRect $ \dst ->+ maybeWith with center $ \c ->+ Raw.renderCopyExF r t (castPtr src) (castPtr dst) theta (castPtr c)+ (case flips of+ V2 x y -> (if x then Raw.SDL_FLIP_HORIZONTAL else 0) .|.+ (if y then Raw.SDL_FLIP_VERTICAL else 0))++-- | Draw a line between two points on the current rendering target.+drawLineF :: MonadIO m => Renderer -> Point V2 CFloat -> Point V2 CFloat -> m ()+drawLineF (Renderer r) (P (V2 x y)) (P (V2 x' y')) = liftIO $+ throwIfNeg_ "SDL.Video.drawLineF" "SDL_RenderDrawLineF" $+ Raw.renderDrawLineF r x y x' y'++-- | Draw a series of connected lines on the current rendering target.+drawLinesF :: MonadIO m => Renderer -> SV.Vector (Point V2 CFloat) -> m ()+drawLinesF (Renderer r) points = liftIO $+ throwIfNeg_ "SDL.Video.drawLinesF" "SDL_RenderDrawLinesF" $+ SV.unsafeWith points $ \p ->+ Raw.renderDrawLinesF r (castPtr p) (fromIntegral (SV.length points))++-- | Draw a point on the current rendering target.+drawPointF :: MonadIO m => Renderer -> Point V2 CFloat -> m ()+drawPointF (Renderer r) (P (V2 x y)) = liftIO $+ throwIfNeg_ "SDL.Video.drawPointF" "SDL_RenderDrawPointF" $+ Raw.renderDrawPointF r x y++-- | Draw a collection of points on the current rendering target.+drawPointsF :: MonadIO m => Renderer -> SV.Vector (Point V2 CFloat) -> m ()+drawPointsF (Renderer r) points = liftIO $+ throwIfNeg_ "SDL.Video.drawPointsF" "SDL_RenderDrawPointsF" $+ SV.unsafeWith points $ \p ->+ Raw.renderDrawPointsF r (castPtr p) (fromIntegral (SV.length points))++-- | Draw the outline of a rectangle on the current rendering target.+drawRectF :: MonadIO m => Renderer -> Rectangle CFloat -> m ()+drawRectF (Renderer r) rect = liftIO $+ throwIfNeg_ "SDL.Video.drawRectF" "SDL_RenderDrawRectF" $+ with rect $ \rectPtr ->+ Raw.renderDrawRectF r (castPtr rectPtr)++-- | Draw a series of rectangle outlines on the current rendering target.+drawRectsF :: MonadIO m => Renderer -> SV.Vector (Rectangle CFloat) -> m ()+drawRectsF (Renderer r) rects = liftIO $+ throwIfNeg_ "SDL.Video.drawRectsF" "SDL_RenderDrawRectsF" $+ SV.unsafeWith rects $ \rp ->+ Raw.renderDrawRectsF r (castPtr rp) (fromIntegral (SV.length rects))++-- | Draw a filled rectangle on the current rendering target.+fillRectF :: MonadIO m => Renderer -> Rectangle CFloat -> m ()+fillRectF (Renderer r) rect = liftIO $+ throwIfNeg_ "SDL.Video.fillRectF" "SDL_RenderFillRectF" $+ with rect $ \rectPtr ->+ Raw.renderFillRectF r (castPtr rectPtr)++-- | Draw a series of filled rectangles on the current rendering target.+fillRectsF :: MonadIO m => Renderer -> SV.Vector (Rectangle CFloat) -> m ()+fillRectsF (Renderer r) rects = liftIO $+ throwIfNeg_ "SDL.Video.fillRectsF" "SDL_RenderFillRectsF" $+ SV.unsafeWith rects $ \rp ->+ Raw.renderFillRectsF r (castPtr rp) (fromIntegral (SV.length rects))++-- | Render a list of triangles, optionally using a texture and indices into the+-- vertex array Color and alpha modulation is done per vertex+-- (SDL_SetTextureColorMod and SDL_SetTextureAlphaMod are ignored).+renderGeometry :: MonadIO m => Renderer -> Maybe Texture -> SV.Vector Raw.Vertex -> SV.Vector CInt -> m ()+renderGeometry (Renderer r) mtexture vertices indices = liftIO $+ throwIfNeg_ "SDL.Video.renderGeometry" "SDL_RenderGeometry" $+ SV.unsafeWith vertices $ \vp ->+ SV.unsafeWith indices $ \ip ->+ Raw.renderGeometry r t vp (fromIntegral (SV.length vertices)) (ipOrNull ip) ipSize+ where+ t = case mtexture of+ Just (Texture found) -> found+ Nothing -> nullPtr++ ipOrNull ip = if ipSize == 0 then nullPtr else ip++ ipSize = fromIntegral (SV.length indices)++-- | Render a list of triangles, optionally using a texture and indices into the+-- vertex array Color and alpha modulation is done per vertex+-- (SDL_SetTextureColorMod and SDL_SetTextureAlphaMod are ignored).+--+-- This version allows storeing vertex data in arbitrary types, but you have to provide+-- pointers and strides yourself.+renderGeometryRaw :: forall ix m . (Storable ix, MonadIO m) => Renderer -> Maybe Texture -> Ptr Raw.FPoint -> CInt -> Ptr Raw.Color -> CInt -> Ptr Raw.FPoint -> CInt -> CInt -> SV.Vector ix -> m ()+renderGeometryRaw (Renderer r) mtexture xy xyStride color colorStride uv uvStride numVertices indices = liftIO $+ throwIfNeg_ "SDL.Video.renderGeometryRaw" "SDL_RenderGeometryRaw" $+ SV.unsafeWith indices $ \ip ->+ Raw.renderGeometryRaw r t xy xyStride color colorStride uv uvStride numVertices (castPtr $ ipOrNull ip) ipSize sizeOfip+ where+ t = case mtexture of+ Just (Texture found) -> found+ Nothing -> nullPtr++ ipOrNull ip = if ipSize == 0 then nullPtr else ip++ ipSize = fromIntegral (SV.length indices)++ sizeOfip = fromIntegral $ sizeOf (undefined :: ix)+#endif++ -- | Clear the current rendering target with the drawing color. ----- See @<https://wiki.libsdl.org/SDL_RenderClear SDL_RenderClear>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderClear SDL_RenderClear>@ for C documentation. clear :: (Functor m, MonadIO m) => Renderer -> m () clear (Renderer r) = throwIfNeg_ "SDL.Video.clear" "SDL_RenderClear" $ Raw.renderClear r+{-# INLINE clear #-} -- | Get or set the drawing scale for rendering on the current target. --@@ -655,7 +849,7 @@ -- -- If this results in scaling or subpixel drawing by the rendering backend, it will be handled using the appropriate quality hints. For best results use integer scaling factors. ----- See @<https://wiki.libsdl.org/SDL_RenderSetScale SDL_RenderSetScale>@ and @<https://wiki.libsdl.org/SDL_RenderGetScale SDL_RenderGetScale>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderSetScale SDL_RenderSetScale>@ and @<https://wiki.libsdl.org/SDL2/SDL_RenderGetScale SDL_RenderGetScale>@ for C documentation. rendererScale :: Renderer -> StateVar (V2 CFloat) rendererScale (Renderer r) = makeStateVar renderGetScale renderSetScale where@@ -663,7 +857,7 @@ throwIfNeg_ "SDL.Video.renderSetScale" "SDL_RenderSetScale" $ Raw.renderSetScale r x y - renderGetScale = liftIO $+ renderGetScale = alloca $ \w -> alloca $ \h -> do Raw.renderGetScale r w h@@ -673,16 +867,15 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_RenderSetClipRect SDL_RenderSetClipRect>@ and @<https://wiki.libsdl.org/SDL_RenderGetClipRect SDL_RenderGetClipRect>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderSetClipRect SDL_RenderSetClipRect>@ and @<https://wiki.libsdl.org/SDL2/SDL_RenderGetClipRect SDL_RenderGetClipRect>@ for C documentation. rendererClipRect :: Renderer -> StateVar (Maybe (Rectangle CInt)) rendererClipRect (Renderer r) = makeStateVar renderGetClipRect renderSetClipRect where- renderGetClipRect = liftIO $+ renderGetClipRect = alloca $ \rPtr -> do Raw.renderGetClipRect r rPtr maybePeek peek (castPtr rPtr) renderSetClipRect rect =- liftIO $ throwIfNeg_ "SDL.Video.renderSetClipRect" "SDL_RenderSetClipRect" $ maybeWith with rect $ Raw.renderSetClipRect r . castPtr @@ -690,17 +883,16 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_RenderSetViewport SDL_RenderSetViewport>@ and @<https://wiki.libsdl.org/SDL_RenderGetViewport SDL_RenderGetViewport>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderSetViewport SDL_RenderSetViewport>@ and @<https://wiki.libsdl.org/SDL2/SDL_RenderGetViewport SDL_RenderGetViewport>@ for C documentation. rendererViewport :: Renderer -> StateVar (Maybe (Rectangle CInt)) rendererViewport (Renderer r) = makeStateVar renderGetViewport renderSetViewport where- renderGetViewport = liftIO $+ renderGetViewport = alloca $ \rect -> do Raw.renderGetViewport r rect maybePeek peek (castPtr rect) renderSetViewport rect =- liftIO $ throwIfNeg_ "SDL.Video.renderSetViewport" "SDL_RenderSetViewport" $ maybeWith with rect $ Raw.renderSetViewport r . castPtr @@ -712,13 +904,13 @@ -- -- The backbuffer should be considered invalidated after each present; do not assume that previous contents will exist between frames. You are strongly encouraged to call 'clear' to initialize the backbuffer before starting each new frame's drawing, even if you plan to overwrite every pixel. ----- See @<https://wiki.libsdl.org/SDL_RenderPresent SDL_RenderPresent>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderPresent SDL_RenderPresent>@ for C documentation. present :: MonadIO m => Renderer -> m () present (Renderer r) = Raw.renderPresent r -- | Copy a portion of the texture to the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderCopy SDL_RenderCopy>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderCopy SDL_RenderCopy>@ for C documentation. copy :: MonadIO m => Renderer -- ^ The rendering context -> Texture -- ^ The source texture@@ -734,16 +926,16 @@ -- | Copy a portion of the texture to the current rendering target, optionally rotating it by angle around the given center and also flipping it top-bottom and/or left-right. ----- See @<https://wiki.libsdl.org/SDL_RenderCopy SDL_RenderCopyEx>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderCopyEx SDL_RenderCopyEx>@ for C documentation. copyEx :: MonadIO m => Renderer -- ^ The rendering context -> Texture -- ^ The source texture -> Maybe (Rectangle CInt) -- ^ The source rectangle to copy, or 'Nothing' for the whole texture -> Maybe (Rectangle CInt) -- ^ The destination rectangle to copy to, or 'Nothing' for the whole rendering target. The texture will be stretched to fill the given rectangle.- -> CDouble -- ^ An angle in degrees that indicates the point around which the destination rectangle will be rotated.- -> Maybe (Point V2 CInt) -- ^ The point of rotation- -> V2 Bool -- ^ Whether to flip in the X or Y axis.- -> m () -- ^ Whether to flip in the X or Y axis.+ -> CDouble -- ^ The angle of rotation in degrees. The rotation will be performed clockwise.+ -> Maybe (Point V2 CInt) -- ^ The point indicating the center of the rotation, or 'Nothing' to rotate around the center of the destination rectangle+ -> V2 Bool -- ^ Whether to flip the texture on the X and/or Y axis+ -> m () copyEx (Renderer r) (Texture t) srcRect dstRect theta center flips = liftIO $ throwIfNeg_ "SDL.Video.copyEx" "SDL_RenderCopyEx" $@@ -757,7 +949,7 @@ -- | Draw a line on the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderDrawLine SDL_RenderDrawLine>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderDrawLine SDL_RenderDrawLine>@ for C documentation. drawLine :: (Functor m,MonadIO m) => Renderer -> Point V2 CInt -- ^ The start point of the line@@ -769,7 +961,7 @@ -- | Draw a series of connected lines on the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderDrawLines SDL_RenderDrawLines>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderDrawLines SDL_RenderDrawLines>@ for C documentation. drawLines :: MonadIO m => Renderer -> SV.Vector (Point V2 CInt) -- ^ A 'SV.Vector' of points along the line. SDL will draw lines between these points.@@ -784,7 +976,7 @@ -- | Draw a point on the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderDrawPoint SDL_RenderDrawPoint>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderDrawPoint SDL_RenderDrawPoint>@ for C documentation. drawPoint :: (Functor m, MonadIO m) => Renderer -> Point V2 CInt -> m () drawPoint (Renderer r) (P (V2 x y)) = throwIfNeg_ "SDL.Video.drawPoint" "SDL_RenderDrawPoint" $@@ -792,7 +984,7 @@ -- | Draw multiple points on the current rendering target. ----- See @<https://wiki.libsdl.org/SDL_RenderDrawPoints SDL_RenderDrawPoints>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderDrawPoints SDL_RenderDrawPoints>@ for C documentation. drawPoints :: MonadIO m => Renderer -> SV.Vector (Point V2 CInt) -> m () drawPoints (Renderer r) points = liftIO $@@ -806,7 +998,7 @@ -- -- This function is used to optimize images for faster repeat blitting. This is accomplished by converting the original and storing the result as a new surface. The new, optimized surface can then be used as the source for future blits, making them faster. ----- See @<https://wiki.libsdl.org/SDL_ConvertSurface SDL_ConvertSurface>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_ConvertSurface SDL_ConvertSurface>@ for C documentation. convertSurface :: (Functor m,MonadIO m) => Surface -- ^ The 'Surface' to convert -> SurfacePixelFormat -- ^ The pixel format that the new surface is optimized for@@ -818,7 +1010,7 @@ -- | Perform a scaled surface copy to a destination surface. ----- See @<https://wiki.libsdl.org/SDL_BlitScaled SDL_BlitScaled>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_BlitScaled SDL_BlitScaled>@ for C documentation. surfaceBlitScaled :: MonadIO m => Surface -- ^ The 'Surface' to be copied from -> Maybe (Rectangle CInt) -- ^ The rectangle to be copied, or 'Nothing' to copy the entire surface@@ -836,12 +1028,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetColorKey SDL_SetColorKey>@ and @<https://wiki.libsdl.org/SDL_GetColorKey SDL_GetColorKey>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetColorKey SDL_SetColorKey>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetColorKey SDL_GetColorKey>@ for C documentation. surfaceColorKey :: Surface -> StateVar (Maybe (V4 Word8)) surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey where getColorKey =- liftIO $ alloca $ \keyPtr -> do ret <- Raw.getColorKey s keyPtr if ret == -1@@ -855,7 +1046,6 @@ do Raw.getRGBA mapped format r g b a Just <$> (V4 <$> peek r <*> peek g <*> peek b <*> peek a) setColorKey key =- liftIO $ throwIfNeg_ "SDL.Video.Renderer.setColorKey" "SDL_SetColorKey" $ case key of Nothing ->@@ -877,11 +1067,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetTextureColorMod SDL_SetTextureColorMod>@ and @<https://wiki.libsdl.org/SDL_GetTextureColorMod SDL_GetTextureColorMod>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetTextureColorMod SDL_SetTextureColorMod>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetTextureColorMod SDL_GetTextureColorMod>@ for C documentation. textureColorMod :: Texture -> StateVar (V3 Word8) textureColorMod (Texture t) = makeStateVar getTextureColorMod setTextureColorMod where- getTextureColorMod = liftIO $+ getTextureColorMod = alloca $ \r -> alloca $ \g -> alloca $ \b -> do@@ -894,7 +1084,7 @@ Raw.setTextureColorMod t r g b data PixelFormat- = Unknown+ = Unknown !Word32 | Index1LSB | Index1MSB | Index4LSB@@ -930,11 +1120,10 @@ | YUY2 | UYVY | YVYU- deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)+ deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) instance FromNumber PixelFormat Word32 where fromNumber n' = case n' of- Raw.SDL_PIXELFORMAT_UNKNOWN -> Unknown Raw.SDL_PIXELFORMAT_INDEX1LSB -> Index1LSB Raw.SDL_PIXELFORMAT_INDEX1MSB -> Index1MSB Raw.SDL_PIXELFORMAT_INDEX4LSB -> Index4LSB@@ -970,11 +1159,12 @@ Raw.SDL_PIXELFORMAT_YUY2 -> YUY2 Raw.SDL_PIXELFORMAT_UYVY -> UYVY Raw.SDL_PIXELFORMAT_YVYU -> YVYU- _ -> error "fromNumber: not numbered"+ Raw.SDL_PIXELFORMAT_UNKNOWN -> Unknown n'+ _ -> Unknown n' instance ToNumber PixelFormat Word32 where toNumber pf = case pf of- Unknown -> Raw.SDL_PIXELFORMAT_UNKNOWN+ Unknown _ -> Raw.SDL_PIXELFORMAT_UNKNOWN Index1LSB -> Raw.SDL_PIXELFORMAT_INDEX1LSB Index1MSB -> Raw.SDL_PIXELFORMAT_INDEX1MSB Index4LSB -> Raw.SDL_PIXELFORMAT_INDEX4LSB@@ -1092,7 +1282,7 @@ -- | Get information about a rendering context. ----- See @<https://wiki.libsdl.org/SDL_GetRendererInfo SDL_GetRendererInfo>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetRendererInfo SDL_GetRendererInfo>@ for C documentation. getRendererInfo :: MonadIO m => Renderer -> m RendererInfo getRendererInfo (Renderer renderer) = liftIO $ alloca $ \rptr -> do@@ -1102,7 +1292,7 @@ -- | Enumerate all known render drivers on the system, and determine their supported features. ----- See @<https://wiki.libsdl.org/SDL_GetRenderDriverInfo SDL_GetRenderDriverInfo>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetRenderDriverInfo SDL_GetRenderDriverInfo>@ for C documentation. getRenderDriverInfo :: MonadIO m => m [RendererInfo] getRenderDriverInfo = liftIO $ do count <- Raw.getNumRenderDrivers@@ -1117,11 +1307,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetTextureAlphaMod SDL_SetTextureAlphaMod>@ and @<https://wiki.libsdl.org/SDL_GetTextureAlphaMod SDL_GetTextureAlphaMod>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetTextureAlphaMod SDL_SetTextureAlphaMod>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetTextureAlphaMod SDL_GetTextureAlphaMod>@ for C documentation. textureAlphaMod :: Texture -> StateVar Word8 textureAlphaMod (Texture t) = makeStateVar getTextureAlphaMod setTextureAlphaMod where- getTextureAlphaMod = liftIO $+ getTextureAlphaMod = alloca $ \x -> do throwIfNeg_ "SDL.Video.Renderer.getTextureAlphaMod" "SDL_GetTextureAlphaMod" $ Raw.getTextureAlphaMod t x@@ -1135,11 +1325,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetTextureBlendMode SDL_SetTextureBlendMode>@ and @<https://wiki.libsdl.org/SDL_GetTextureBlendMode SDL_GetTextureBlendMode>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetTextureBlendMode SDL_SetTextureBlendMode>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetTextureBlendMode SDL_GetTextureBlendMode>@ for C documentation. textureBlendMode :: Texture -> StateVar BlendMode textureBlendMode (Texture t) = makeStateVar getTextureBlendMode setTextureBlendMode where- getTextureBlendMode = liftIO $+ getTextureBlendMode = alloca $ \x -> do throwIfNeg_ "SDL.Video.Renderer.getTextureBlendMode" "SDL_GetTextureBlendMode" $ Raw.getTextureBlendMode t x@@ -1149,15 +1339,60 @@ throwIfNeg_ "SDL.Video.Renderer.setTextureBlendMode" "SDL_SetTextureBlendMode" $ Raw.setTextureBlendMode t (toNumber bm) +#ifdef RECENT_ISH++-- | Scale modes used in copy operations+data ScaleMode+ = ScaleModeNearest+ -- ^ Nearest-neighbor scaling+ | ScaleModeLinear+ -- ^ Linear scaling+ | ScaleModeBest+ -- ^ anisotropic filtering+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++instance FromNumber ScaleMode Word32 where+ fromNumber n = case n of+ Raw.SDL_ScaleModeNearest -> ScaleModeNearest+ Raw.SDL_ScaleModeLinear -> ScaleModeLinear+ Raw.SDL_ScaleModeBest -> ScaleModeBest+ _ -> error $ "fromNumber <ScaleMode>: unkonwn scale mode: " ++ (show n)++instance ToNumber ScaleMode Word32 where+ toNumber ScaleModeNearest = Raw.SDL_ScaleModeNearest+ toNumber ScaleModeLinear = Raw.SDL_ScaleModeLinear+ toNumber ScaleModeBest = Raw.SDL_ScaleModeBest++-- | Get or set the scale mode use for texture scale operations.+--+-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_GetTextureScaleMode SDL_GetTextureScaleMode>@ and @<https://wiki.libsdl.org/SDL2/SDL_SetTextureScaleMode SDL_SetTextureScaleMode>@+textureScaleMode :: Texture -> StateVar ScaleMode+textureScaleMode (Texture t) = makeStateVar getTextureScaleMode setTextureScaleMode+ where+ getTextureScaleMode =+ alloca $ \x -> do+ throwIfNeg_ "SDL.Video.Renderer.getTextureScaleMode" "SDL_GetTextureScaleMode" $+ Raw.getTextureScaleMode t x+ fromNumber <$> peek x++ setTextureScaleMode sm =+ throwIfNeg_ "SDL.Video.Renderer.setTextureScaleMode" "SDL_SetTextureScaleMode" $+ Raw.setTextureScaleMode t (toNumber sm)++#endif++ -- | Get or set the blend mode used for blit operations. -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetSurfaceBlendMode SDL_SetSurfaceBlendMode>@ and @<https://wiki.libsdl.org/SDL_GetSurfaceBlendMode SDL_GetSurfaceBlendMode>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetSurfaceBlendMode SDL_SetSurfaceBlendMode>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetSurfaceBlendMode SDL_GetSurfaceBlendMode>@ for C documentation. surfaceBlendMode :: Surface -> StateVar BlendMode surfaceBlendMode (Surface s _) = makeStateVar getSurfaceBlendMode setSurfaceBlendMode where- getSurfaceBlendMode = liftIO $+ getSurfaceBlendMode = alloca $ \x -> do throwIfNeg_ "SDL.Video.Renderer.getSurfaceBlendMode" "SDL_GetSurfaceBlendMode" $ Raw.getSurfaceBlendMode s x@@ -1171,7 +1406,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_SetRenderTarget SDL_SetRenderTarget>@ and @<https://wiki.libsdl.org/SDL_GetRenderTarget SDL_GetRenderTarget>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_SetRenderTarget SDL_SetRenderTarget>@ and @<https://wiki.libsdl.org/SDL2/SDL_GetRenderTarget SDL_GetRenderTarget>@ for C documentation. rendererRenderTarget :: Renderer -> StateVar (Maybe Texture) rendererRenderTarget (Renderer r) = makeStateVar getRenderTarget setRenderTarget where@@ -1188,15 +1423,32 @@ Nothing -> Raw.setRenderTarget r nullPtr Just (Texture t) -> Raw.setRenderTarget r t --- | Get or set the device independent resolution for rendering.+-- | Get or set whether to force integer scales for resolution-independent rendering.+-- It may be desirable to enable integer scales when using device independent resolution+-- via 'rendererLogicalSize' so that pixel sizing is consistent. -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. ----- See @<https://wiki.libsdl.org/SDL_RenderSetLogicalSize SDL_RenderSetLogicalSize>@ and @<https://wiki.libsdl.org/SDL_RenderGetLogicalSize SDL_RenderGetLogicalSize>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderSetIntegerScale SDL_RenderSetIntegerScale>@ and @<https://wiki.libsdl.org/SDL2/SDL_RenderGetIntegerScale SDL_RenderGetIntegerScale>@ for C documentation.+rendererIntegerScale :: Renderer -> StateVar Bool+rendererIntegerScale (Renderer r) = makeStateVar renderGetIntegerScale renderSetIntegerScale+ where+ renderGetIntegerScale = (== 1) <$> Raw.renderGetIntegerScale r++ renderSetIntegerScale True = void $ Raw.renderSetIntegerScale r 1+ renderSetIntegerScale False = void $ Raw.renderSetIntegerScale r 0++-- | Get or set the device independent resolution for rendering. When using this setting,+-- it may be desirable to also enable integer scales via 'rendererIntegerScale' so that+-- pixel sizing is consistent.+--+-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'.+--+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderSetLogicalSize SDL_RenderSetLogicalSize>@ and @<https://wiki.libsdl.org/SDL2/SDL_RenderGetLogicalSize SDL_RenderGetLogicalSize>@ for C documentation. rendererLogicalSize :: Renderer -> StateVar (Maybe (V2 CInt)) rendererLogicalSize (Renderer r) = makeStateVar renderGetLogicalSize renderSetLogicalSize where- renderGetLogicalSize = liftIO $+ renderGetLogicalSize = alloca $ \w -> do alloca $ \h -> do Raw.renderGetLogicalSize r w h@@ -1211,13 +1463,13 @@ -- | Determine whether a window supports the use of render targets. ----- See @<https://wiki.libsdl.org/SDL_RenderTargetSupported SDL_RenderTargetSupported>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_RenderTargetSupported SDL_RenderTargetSupported>@ for C documentation. renderTargetSupported :: (MonadIO m) => Renderer -> m Bool renderTargetSupported (Renderer r) = Raw.renderTargetSupported r -- | Convert the given the enumerated pixel format to a bpp value and RGBA masks. ----- See @<https://wiki.libsdl.org/SDL_PixelFormatEnumToMasks SDL_PixelFormatEnumToMasks>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_PixelFormatEnumToMasks SDL_PixelFormatEnumToMasks>@ for C documentation. pixelFormatToMasks :: (MonadIO m) => PixelFormat -> m (CInt, V4 Word32) pixelFormatToMasks pf = liftIO $ alloca $ \bpp ->@@ -1233,7 +1485,7 @@ -- | Convert a bpp value and RGBA masks to an enumerated pixel format. ----- See @<https://wiki.libsdl.org/SDL_MasksToPixelFormatEnum SDL_MasksToPixelFormatEnum>@ for C documentation.+-- See @<https://wiki.libsdl.org/SDL2/SDL_MasksToPixelFormatEnum SDL_MasksToPixelFormatEnum>@ for C documentation. masksToPixelFormat :: (MonadIO m) => CInt -> V4 Word32 -> m PixelFormat masksToPixelFormat bpp (V4 r g b a) = liftIO $ fromNumber <$> Raw.masksToPixelFormatEnum bpp r g b a
+ src/SDL/Video/Vulkan.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module SDL.Video.Vulkan (+ -- * Vulkan types+ VkInstance, VkSurfaceKHR, VkGetInstanceProcAddrFunc,+ -- * Vulkan loader+ vkLoadLibrary, vkUnloadLibrary, vkGetVkGetInstanceProcAddr,+ -- * Vulkan surface+ vkGetInstanceExtensions, vkCreateSurface,+ -- * Querying for the drawable size+ vkGetDrawableSize+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Foreign hiding (throwIf_, throwIfNeg_)+import Foreign.C.Types (CInt)+import Foreign.C.String (CString, withCString)+import SDL.Vect (V2 (V2))+import SDL.Internal.Exception (throwIf_, throwIfNeg_)+import SDL.Internal.Types (Window (Window))+import SDL.Raw.Types (VkInstance, VkSurfaceKHR, VkGetInstanceProcAddrFunc)+import qualified SDL.Raw as Raw++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++-- | Dynamically load a Vulkan loader library.+--+-- If a filePath is 'Nothing', SDL will use the value of the environment variable+-- SDL_VULKAN_LIBRARY, if set, otherwise it loads the default Vulkan+-- loader library.+--+-- This function should be called after initializing the video driver+-- (i.e. 'SDL.Init.initialize' ['SDL.Init.InitVideo']), but before+-- creating any windows with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.+--+-- If no Vulkan loader library is loaded, analogue of 'vkLoadLibrary' 'Nothing'+-- will be automatically called by SDL C library upon creation of the first Vulkan window.+--+-- Throws 'SDL.Exception.SDLException' if there are no working Vulkan drivers installed.+vkLoadLibrary :: MonadIO m => Maybe FilePath -> m ()+vkLoadLibrary = \case+ Nothing -> liftIO . testNeg $ Raw.vkLoadLibrary nullPtr+ Just filePath -> liftIO . withCString filePath $ testNeg . Raw.vkLoadLibrary+ where+ testNeg = throwIfNeg_ "SDL.Video.Vulkan.vkLoadLibrary" "SDL_Vulkan_LoadLibrary"++-- | Unload the Vulkan loader library previously loaded by 'vkLoadLibrary'.+--+-- Analogue of this function will be automatically called by SDL C library+-- after destruction of the last window with+-- 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.+vkUnloadLibrary :: MonadIO m => m ()+vkUnloadLibrary = Raw.vkUnloadLibrary++foreign import ccall "dynamic" mkVkGetInstanceProcAddrFunc ::+ FunPtr VkGetInstanceProcAddrFunc -> VkGetInstanceProcAddrFunc++-- | Get the vkGetInstanceProcAddr function, which can be used to obtain another Vulkan functions+-- (see <https://www.khronos.org/registry/vulkan/specs/1.0/man/html/vkGetInstanceProcAddr.html>).+--+-- The 'vkGetVkGetInstanceProcAddr' function should be called after either calling 'vkLoadLibrary'+-- function or creating first Vulkan window.+vkGetVkGetInstanceProcAddr :: (Functor m, MonadIO m) => m VkGetInstanceProcAddrFunc+vkGetVkGetInstanceProcAddr = mkVkGetInstanceProcAddrFunc <$> Raw.vkGetVkGetInstanceProcAddr++-- | Get the names of the Vulkan instance extensions needed to create+-- a surface with 'vkCreateSurface'.+--+-- The extension names queried here must be enabled when calling vkCreateInstance+-- (see <https://www.khronos.org/registry/vulkan/specs/1.0/man/html/vkCreateInstance.html>),+-- otherwise 'vkCreateSurface' will fail.+--+-- Window should have been created with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.+--+-- Throws 'SDL.Exception.SDLException' on failure.+vkGetInstanceExtensions :: MonadIO m => Window -> m [CString]+vkGetInstanceExtensions (Window w) = liftIO . alloca $ \countPtr -> do+ throwIf_ not "SDL.Video.Vulkan.vkGetInstanceExtensions (1)" "SDL_Vulkan_GetInstanceExtensions" $+ Raw.vkGetInstanceExtensions w countPtr nullPtr+ count <- fromIntegral <$> peek countPtr+ allocaArray count $ \sPtr ->+ throwIf_ not "SDL.Video.Vulkan.vkGetInstanceExtensions (2)" "SDL_Vulkan_GetInstanceExtensions"+ (Raw.vkGetInstanceExtensions w countPtr sPtr) >> peekArray count sPtr++-- | Create a Vulkan rendering surface for a window.+--+-- Window should have been created with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'.+--+-- Instance should have been created with the extensions returned+-- by 'vkGetInstanceExtensions' enabled.+--+-- Throws 'SDL.Exception.SDLException' on failure.+vkCreateSurface :: MonadIO m => Window -> VkInstance -> m VkSurfaceKHR+vkCreateSurface (Window w) vkInstance = liftIO . alloca $ \vkSurfacePtr ->+ throwIf_ not "SDL.Video.Vulkan.vkCreateSurface" "SDL_Vulkan_CreateSurface"+ (Raw.vkCreateSurface w vkInstance vkSurfacePtr) >> peek vkSurfacePtr++-- | Get the size of a window's underlying drawable area in pixels (for use+-- with setting viewport, scissor & etc).+--+-- It may differ from 'SDL.Video.windowSize' if window was created with 'SDL.Video.windowHighDPI' flag.+vkGetDrawableSize :: MonadIO m => Window -> m (V2 CInt)+vkGetDrawableSize (Window w) = liftIO . alloca $ \wptr ->+ alloca $ \hptr -> do+ Raw.vkGetDrawableSize w wptr hptr+ V2 <$> peek wptr <*> peek hptr