diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,93 @@ +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 ======= @@ -11,7 +101,7 @@ 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 diff --git a/bench/Space.hs b/bench/Space.hs --- a/bench/Space.hs +++ b/bench/Space.hs @@ -44,9 +44,9 @@ (\weight -> if weightGCs weight > 0 then Just "Non-zero number of garbage collections!" - else if weightAllocatedBytes weight > 3000 + else if weightAllocatedBytes weight > 4000 then Just - "Allocated >3KB! Allocations should be constant." + "Allocated >4KB! Allocations should be constant." else Nothing) | i <- [1, 10, 100, 1000, 10000] ]) diff --git a/cbits/sdlhelper.c b/cbits/sdlhelper.c --- a/cbits/sdlhelper.c +++ b/cbits/sdlhelper.c @@ -1,5 +1,16 @@ #include +#include #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) { diff --git a/examples/AudioExample.hs b/examples/AudioExample.hs --- a/examples/AudioExample.hs +++ b/examples/AudioExample.hs @@ -13,8 +13,8 @@ sinSamples = map (\n -> let t = fromIntegral n / 48000 :: Double - freq = 440 * 4 - in round (fromIntegral (maxBound `div` 2 :: Int16) * sin (t * freq))) + 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 () diff --git a/examples/EventWatch.hs b/examples/EventWatch.hs --- a/examples/EventWatch.hs +++ b/examples/EventWatch.hs @@ -14,22 +14,24 @@ import SDL +import Control.Monad (void) + main :: IO () main = do initializeAll window <- createWindow "resize" WindowConfig { - windowBorder = True - , windowHighDPI = False - , windowInputGrabbed = False - , windowMode = Windowed - , windowOpenGL = Nothing - , windowPosition = Wherever - , windowResizable = True - , windowInitialSize = V2 800 600 - , windowVisible = True + 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 - addEventWatch $ \ev -> + _renderer <- createRenderer window (-1) defaultRenderer + void . addEventWatch $ \ev -> case eventPayload ev of WindowSizeChangedEvent sizeChangeData -> putStrLn $ "eventWatch windowSizeChanged: " ++ show sizeChangeData @@ -48,5 +50,16 @@ 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 diff --git a/examples/OpenGLExample.hs b/examples/OpenGLExample.hs --- a/examples/OpenGLExample.hs +++ b/examples/OpenGLExample.hs @@ -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 diff --git a/examples/RenderGeometry.hs b/examples/RenderGeometry.hs new file mode 100644 --- /dev/null +++ b/examples/RenderGeometry.hs @@ -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 diff --git a/examples/UserEvents.hs b/examples/UserEvents.hs --- a/examples/UserEvents.hs +++ b/examples/UserEvents.hs @@ -1,6 +1,7 @@ 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 @@ -26,7 +27,7 @@ case registeredEvent of Nothing -> putStrLn "Fatal error: unable to register timer events." Just registeredTimerEvent -> do - addTimer 1000 $ mkTimerCb registeredTimerEvent + void . addTimer 1000 $ mkTimerCb registeredTimerEvent putStrLn "press q at any time to quit" appLoop registeredTimerEvent @@ -40,7 +41,7 @@ return $ Reschedule interval appLoop :: RegisteredEventType TimerEvent -> IO () -appLoop (RegisteredEventType pushTimerEvent getTimerEvent) = waitEvent >>= go +appLoop (RegisteredEventType _pushTimerEvent getTimerEvent) = waitEvent >>= go where go :: Event -> IO () go ev = diff --git a/examples/lazyfoo/Lesson02.hs b/examples/lazyfoo/Lesson02.hs --- a/examples/lazyfoo/Lesson02.hs +++ b/examples/lazyfoo/Lesson02.hs @@ -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 diff --git a/examples/lazyfoo/Lesson03.hs b/examples/lazyfoo/Lesson03.hs --- a/examples/lazyfoo/Lesson03.hs +++ b/examples/lazyfoo/Lesson03.hs @@ -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 diff --git a/examples/lazyfoo/Lesson04.hs b/examples/lazyfoo/Lesson04.hs --- a/examples/lazyfoo/Lesson04.hs +++ b/examples/lazyfoo/Lesson04.hs @@ -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) diff --git a/examples/twinklebear/Lesson05.hs b/examples/twinklebear/Lesson05.hs --- a/examples/twinklebear/Lesson05.hs +++ b/examples/twinklebear/Lesson05.hs @@ -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 diff --git a/include/sdlhelper.h b/include/sdlhelper.h --- a/include/sdlhelper.h +++ b/include/sdlhelper.h @@ -4,6 +4,8 @@ #include #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); diff --git a/sdl2.cabal b/sdl2.cabal --- a/sdl2.cabal +++ b/sdl2.cabal @@ -1,6 +1,6 @@ name: sdl2 -version: 2.4.1.0 -synopsis: Both high- and low-level bindings to the SDL library (version 2.0.4+). +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: @@ -45,18 +45,30 @@ 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 @@ -78,6 +90,7 @@ SDL.Video SDL.Video.OpenGL SDL.Video.Renderer + SDL.Video.Vulkan SDL.Internal.Exception SDL.Internal.Numbered @@ -113,29 +126,41 @@ includes: SDL.h + SDL_vulkan.h sdlhelper.h extra-libraries: SDL2 - pkgconfig-depends: - sdl2 >= 2.0.4 + 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, + bytestring >= 0.10.4.0 && < 0.13, exceptions >= 0.4 && < 0.11, - 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 + 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 @@ -480,6 +505,18 @@ 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 diff --git a/src/SDL.hs b/src/SDL.hs --- a/src/SDL.hs +++ b/src/SDL.hs @@ -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: @@ -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 diff --git a/src/SDL/Audio.hs b/src/SDL/Audio.hs --- a/src/SDL/Audio.hs +++ b/src/SDL/Audio.hs @@ -54,13 +54,7 @@ , getAudioDeviceNames -- * 'AudioSpec' - , AudioSpec - , audioSpecFreq - , audioSpecFormat - , audioSpecChannels - , audioSpecSilence - , audioSpecSize - , audioSpecCallback + , AudioSpec(..) -- * Audio Drivers , getAudioDrivers @@ -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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. closeAudioDevice :: MonadIO m => AudioDevice -> m () closeAudioDevice (AudioDevice d) = Raw.closeAudioDevice d diff --git a/src/SDL/Event.hs b/src/SDL/Event.hs --- a/src/SDL/Event.hs +++ b/src/SDL/Event.hs @@ -109,10 +109,10 @@ 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 :: Timestamp - -- ^ The time the event occured. + -- ^ The time the event occurred. , eventPayload :: EventPayload -- ^ Data pertaining to this event. } deriving (Eq, Ord, Generic, Show, Typeable) @@ -396,7 +396,7 @@ data JoyDeviceEventData = JoyDeviceEventData {joyDeviceEventConnection :: !JoyDeviceConnection -- ^ Was the device added or removed? - ,joyDeviceEventWhich :: !Int32 + ,joyDeviceEventWhich :: !Raw.JoystickID -- ^ The instance id of the joystick that reported the event. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -405,7 +405,7 @@ data ControllerAxisEventData = ControllerAxisEventData {controllerAxisEventWhich :: !Raw.JoystickID -- ^ The joystick instance ID that reported the event. - ,controllerAxisEventAxis :: !Word8 + ,controllerAxisEventAxis :: !ControllerAxis -- ^ The index of the axis. ,controllerAxisEventValue :: !Int16 -- ^ The axis value ranging between -32768 and 32767. @@ -427,8 +427,8 @@ data ControllerDeviceEventData = ControllerDeviceEventData {controllerDeviceEventConnection :: !ControllerDeviceConnection -- ^ Was the device added, removed, or remapped? - ,controllerDeviceEventWhich :: !Int32 - -- ^ The joystick instance ID that reported the event. + ,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) @@ -681,11 +681,15 @@ 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))) + return (Event ts + (ControllerAxisEvent + (ControllerAxisEventData a + (fromNumber $ fromIntegral b) + c))) convertRaw (Raw.ControllerButtonEvent t ts a b _) = - return (Event ts + return (Event ts (ControllerButtonEvent - (ControllerButtonEventData a + (ControllerButtonEventData a (fromNumber $ fromIntegral b) (fromNumber t)))) convertRaw (Raw.ControllerDeviceEvent t ts a) = @@ -744,7 +748,8 @@ 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 $ do @@ -753,19 +758,31 @@ if n == 0 then return Nothing else alloca $ \e -> do - n <- Raw.pollEvent e + n' <- Raw.pollEvent e -- Checking 0 again doesn't hurt and it's good to be safe. - if n == 0 + 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. -- @@ -858,7 +875,7 @@ 0 -> return $ EventPushFiltered _ -> EventPushFailure <$> getError - getEv (Event ts (UserEvent (UserEventData typ mWin code d1 d2))) = + getEv (Event ts (UserEvent (UserEventData _typ mWin code d1 d2))) = registeredEventDataToEvent (RegisteredEventData mWin code d1 d2) ts getEv _ = return Nothing @@ -868,11 +885,11 @@ -- -- 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 @@ for C documentation. +-- See @@ for C documentation. pumpEvents :: MonadIO m => m () pumpEvents = Raw.pumpEvents @@ -884,7 +901,7 @@ -- | Trigger an 'EventWatchCallback' when an event is added to the SDL -- event queue. -- --- See @@ for C documentation. +-- See @@ for C documentation. addEventWatch :: MonadIO m => EventWatchCallback -> m EventWatch addEventWatch callback = liftIO $ do rawFilter <- Raw.mkEventFilter wrappedCb @@ -901,12 +918,12 @@ -- | Remove an 'EventWatch'. -- --- See @@ for C documentation. +-- See @@ 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 id = do - rawWindow <- Raw.getWindowFromID id +getWindowFromID windowId = do + rawWindow <- Raw.getWindowFromID windowId return $ if rawWindow == nullPtr then Nothing else Just $ Window rawWindow diff --git a/src/SDL/Hint.hs b/src/SDL/Hint.hs --- a/src/SDL/Hint.hs +++ b/src/SDL/Hint.hs @@ -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 --- . This type has instances for +-- . 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 diff --git a/src/SDL/Input/GameController.hs b/src/SDL/Input/GameController.hs --- a/src/SDL/Input/GameController.hs +++ b/src/SDL/Input/GameController.hs @@ -1,22 +1,219 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module SDL.Input.GameController - ( ControllerButton(..) - , ControllerButtonState(..) - , ControllerDeviceConnection(..) + ( 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 + @@ + (on GitHub). + + See @@ 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 @@ 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 @@ 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 @@ -56,6 +253,25 @@ 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 @@ -69,7 +285,40 @@ Raw.SDL_CONTROLLERBUTTONUP -> ControllerButtonReleased _ -> ControllerButtonInvalidState --- | Identified whether the game controller was added, removed, or remapped. +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 diff --git a/src/SDL/Input/Joystick.hs b/src/SDL/Input/Joystick.hs --- a/src/SDL/Input/Joystick.hs +++ b/src/SDL/Input/Joystick.hs @@ -71,7 +71,7 @@ -- | Count the number of joysticks attached to the system. -- --- See @@ for C documentation. +-- See @@ for C documentation. numJoysticks :: MonadIO m => m (CInt) numJoysticks = throwIfNeg "SDL.Input.Joystick.availableJoysticks" "SDL_NumJoysticks" Raw.numJoysticks @@ -89,7 +89,7 @@ -- | Open a joystick so that you can start receiving events from interaction with this joystick. -- --- See @@ for C documentation. +-- See @@ for C documentation. openJoystick :: (Functor m,MonadIO m) => JoystickDevice -- ^ The device to open. Use 'availableJoysticks' to find 'JoystickDevices's -> m Joystick @@ -100,22 +100,22 @@ -- | Close a joystick previously opened with 'openJoystick'. -- --- See @@ for C documentation. +-- See @@ 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 @@ for C documentation. -getJoystickID :: MonadIO m => Joystick -> m (Int32) +-- See @@ 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 @@ for C documentation. +-- See @@ 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. @@ -124,7 +124,7 @@ -- | Get the ball axis change since the last poll. -- --- See @@ for C documentation. +-- See @@ 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. @@ -145,25 +145,25 @@ -- -- Some joysticks use axes 2 and 3 for extra buttons. -- --- See @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. numBalls :: (MonadIO m) => Joystick -> m CInt numBalls (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numBalls" "SDL_JoystickNumBalls" (Raw.joystickNumBalls j) @@ -195,7 +195,7 @@ -- | Get current position of a POV hat on a joystick. -- --- See @@ for C documentation. +-- See @@ 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. @@ -204,7 +204,7 @@ -- | Get the number of POV hats on a joystick. -- --- See @@ for C documentation. +-- See @@ for C documentation. numHats :: (MonadIO m) => Joystick -> m CInt numHats (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numHats" "SDL_JoystickNumHats" (Raw.joystickNumHats j) diff --git a/src/SDL/Input/Keyboard.hs b/src/SDL/Input/Keyboard.hs --- a/src/SDL/Input/Keyboard.hs +++ b/src/SDL/Input/Keyboard.hs @@ -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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. stopTextInput :: MonadIO m => m () stopTextInput = Raw.stopTextInput -- | Check whether the platform has screen keyboard support. -- --- See @@ for C documentation. +-- See @@ for C documentation. hasScreenKeyboardSupport :: MonadIO m => m Bool hasScreenKeyboardSupport = Raw.hasScreenKeyboardSupport -- | Check whether the screen keyboard is shown for the given window. -- --- See @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. getKeyboardState :: MonadIO m => m (Scancode -> Bool) getKeyboardState = liftIO $ do alloca $ \nkeys -> do diff --git a/src/SDL/Input/Keyboard/Codes.hs b/src/SDL/Input/Keyboard/Codes.hs --- a/src/SDL/Input/Keyboard/Codes.hs +++ b/src/SDL/Input/Keyboard/Codes.hs @@ -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 #-} {-| diff --git a/src/SDL/Input/Mouse.hs b/src/SDL/Input/Mouse.hs --- a/src/SDL/Input/Mouse.hs +++ b/src/SDL/Input/Mouse.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} module SDL.Input.Mouse ( -- * Relative Mouse Mode @@ -17,6 +16,7 @@ , MouseScrollDirection(..) -- * Mouse State + , ModalLocation(..) , getModalMouseLocation , getAbsoluteMouseLocation , getRelativeMouseLocation @@ -31,10 +31,13 @@ -- * Cursor Shape , Cursor + , SystemCursor(..) , activeCursor , createCursor + , createCursorFrom , freeCursor , createColorCursor + , createSystemCursor ) where import Control.Monad (void) @@ -42,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 @@ -64,6 +68,10 @@ import Control.Applicative #endif +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif + data LocationMode = AbsoluteLocation | RelativeLocation @@ -169,7 +177,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. cursorVisible :: StateVar Bool cursorVisible = makeStateVar getCursorVisible setCursorVisible where @@ -208,11 +216,40 @@ 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 @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. activeCursor :: StateVar Cursor activeCursor = makeStateVar getCursor setCursor where @@ -225,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 @@ for C documentation. +-- See @@ for C documentation. freeCursor :: MonadIO m => Cursor -> m () freeCursor = Raw.freeCursor . unwrapCursor -- | Create a color cursor. -- --- See @@ for C documentation. +-- See @@ for C documentation. createColorCursor :: MonadIO m => Surface -> Point V2 CInt -- ^ The location of the cursor hot spot @@ -257,3 +360,12 @@ liftIO . fmap Cursor $ throwIfNull "SDL.Input.Mouse.createColorCursor" "SDL_createColorCursor" $ Raw.createColorCursor surfPtr hx hy + +-- | Create system cursor. +-- +-- See @@ 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) diff --git a/src/SDL/Internal/Types.hs b/src/SDL/Internal/Types.hs --- a/src/SDL/Internal/Types.hs +++ b/src/SDL/Internal/Types.hs @@ -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) diff --git a/src/SDL/Internal/Vect.hs b/src/SDL/Internal/Vect.hs --- a/src/SDL/Internal/Vect.hs +++ b/src/SDL/Internal/Vect.hs @@ -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 diff --git a/src/SDL/Power.hs b/src/SDL/Power.hs --- a/src/SDL/Power.hs +++ b/src/SDL/Power.hs @@ -27,7 +27,7 @@ -- -- Throws 'SDLException' if the current power state can not be determined. -- --- See @@ for C documentation. +-- See @@ for C documentation. getPowerInfo :: (Functor m, MonadIO m) => m PowerState getPowerInfo = liftIO $ diff --git a/src/SDL/Raw/Enum.hsc b/src/SDL/Raw/Enum.hsc --- a/src/SDL/Raw/Enum.hsc +++ b/src/SDL/Raw/Enum.hsc @@ -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, @@ -663,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, @@ -898,10 +935,27 @@ 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 @@ -917,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) @@ -931,6 +987,9 @@ 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) @@ -958,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 @@ -1557,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 @@ -1767,8 +1849,25 @@ 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) diff --git a/src/SDL/Raw/Event.hs b/src/SDL/Raw/Event.hs --- a/src/SDL/Raw/Event.hs +++ b/src/SDL/Raw/Event.hs @@ -96,6 +96,7 @@ gameControllerClose, gameControllerEventState, gameControllerFromInstanceID, + gameControllerFromPlayerIndex, gameControllerGetAttached, gameControllerGetAxis, gameControllerGetAxisFromString, @@ -104,6 +105,12 @@ gameControllerGetButton, gameControllerGetButtonFromString, gameControllerGetJoystick, + gameControllerGetNumTouchpadFingers, + gameControllerGetNumTouchpads, + gameControllerGetPlayerIndex, + gameControllerHasLED, + gameControllerHasRumble, + gameControllerHasRumbleTriggers, gameControllerGetStringForAxis, gameControllerGetStringForButton, gameControllerMapping, @@ -112,7 +119,13 @@ gameControllerNameForIndex, gameControllerOpen, gameControllerUpdate, - isGameController + gameControllerRumble, + gameControllerRumbleTriggers, + gameControllerSetLED, + gameControllerSetPlayerIndex, + isGameController, + eventBuffer, + eventBufferSize ) where import Control.Monad.IO.Class @@ -217,6 +230,7 @@ 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 @@ -225,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 @@ -233,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 #-} @@ -600,6 +627,10 @@ 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 #-} @@ -636,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 #-} @@ -669,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 diff --git a/src/SDL/Raw/Timer.hs b/src/SDL/Raw/Timer.hs --- a/src/SDL/Raw/Timer.hs +++ b/src/SDL/Raw/Timer.hs @@ -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 diff --git a/src/SDL/Raw/Types.hsc b/src/SDL/Raw/Types.hsc --- a/src/SDL/Raw/Types.hsc +++ b/src/SDL/Raw/Types.hsc @@ -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 @@ -463,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 @@ -537,7 +552,7 @@ 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 @@ -801,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 @@ -830,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 @@ -870,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 @@ -966,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 @@ -1138,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 @@ -1153,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 @@ -1172,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 @@ -1191,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 @@ -1212,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 @@ -1239,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 @@ -1265,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 @@ -1287,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 @@ -1315,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 @@ -1333,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 @@ -1346,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 @@ -1357,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 @@ -1385,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 @@ -1414,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 @@ -1441,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 diff --git a/src/SDL/Raw/Video.hs b/src/SDL/Raw/Video.hs --- a/src/SDL/Raw/Video.hs +++ b/src/SDL/Raw/Video.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module SDL.Raw.Video ( -- * Display and Window Management createWindow, @@ -32,11 +34,13 @@ getDisplayDPI, getDisplayMode, getDisplayName, + getDisplayUsableBounds, getGrabbedWindow, getNumDisplayModes, getNumVideoDisplays, getNumVideoDrivers, getVideoDriver, + getWindowBordersSize, getWindowBrightness, getWindowData, getWindowDisplayIndex, @@ -48,6 +52,7 @@ getWindowID, getWindowMaximumSize, getWindowMinimumSize, + getWindowOpacity, getWindowPixelFormat, getWindowPosition, getWindowSize, @@ -69,6 +74,7 @@ setWindowIcon, setWindowMaximumSize, setWindowMinimumSize, + setWindowOpacity, setWindowPosition, setWindowSize, setWindowTitle, @@ -81,6 +87,7 @@ videoQuit, -- * 2D Accelerated Rendering + composeCustomBlendMode, createRenderer, createSoftwareRenderer, createTexture, @@ -112,7 +119,24 @@ 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, @@ -120,6 +144,7 @@ renderPresent, renderReadPixels, renderSetClipRect, + renderSetIntegerScale, renderSetLogicalSize, renderSetScale, renderSetViewport, @@ -195,7 +220,15 @@ -- * Clipboard Handling getClipboardText, hasClipboardText, - setClipboardText + setClipboardText, + + -- * Vulkan support functions + vkLoadLibrary, + vkGetVkGetInstanceProcAddr, + vkUnloadLibrary, + vkGetInstanceExtensions, + vkCreateSurface, + vkGetDrawableSize ) where import Control.Monad.IO.Class @@ -239,11 +272,13 @@ 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 @@ -255,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 () @@ -276,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 () @@ -287,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 @@ -316,9 +354,26 @@ 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 () @@ -326,6 +381,7 @@ 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 @@ -396,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 #-} @@ -524,6 +587,10 @@ 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 #-} @@ -544,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 #-} @@ -588,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 #-} @@ -672,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 #-} @@ -712,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 #-} @@ -836,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 #-} @@ -868,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 #-} @@ -1135,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 #-} diff --git a/src/SDL/Time.hs b/src/SDL/Time.hs --- a/src/SDL/Time.hs +++ b/src/SDL/Time.hs @@ -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) @@ -29,13 +35,13 @@ -- | Number of milliseconds since library initialization. -- --- See @@ for C documentation. +-- See @@ 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 @@ and @@ for C documentation about the implementation. +-- This time is derived from the system's performance counter - see @@ and @@ 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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. removeTimer :: MonadIO m => Timer -> m Bool removeTimer f = liftIO $ runTimerRemoval f + +#ifdef RECENT_ISH +-- | Number of milliseconds since library initialization. +-- +-- See @@ for C documentation. +ticks64 :: MonadIO m => m Word64 +ticks64 = Raw.getTicks64 +#endif diff --git a/src/SDL/Video.hs b/src/SDL/Video.hs --- a/src/SDL/Video.hs +++ b/src/SDL/Video.hs @@ -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 @@ -79,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 @@ -103,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' @@ -120,9 +124,10 @@ , 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 ms p) = do let (msk, v0, v1, flg) = case p of @@ -152,42 +157,59 @@ -- -- @ -- 'defaultWindow' = 'WindowConfig' --- { 'windowBorder' = True --- , 'windowHighDPI' = False --- , 'windowInputGrabbed' = False --- , 'windowMode' = 'Windowed' --- , 'windowOpenGL' = Nothing --- , 'windowPosition' = 'Wherever' --- , 'windowResizable' = False --- , 'windowInitialSize' = V2 800 600 --- , 'windowVisible' = True +-- { '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 - , windowVisible = True + { 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 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' to get size in pixels. - , windowVisible :: Bool -- ^ Defaults to 'True'. + { 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 @@ -206,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 @@ -276,6 +298,11 @@ Minimized -> Raw.minimizeWindow 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 @@ -292,13 +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 @@ 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' to get size in pixels. +-- 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 @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. windowSize :: Window -> StateVar (V2 CInt) windowSize (Window win) = makeStateVar getWindowSize setWindowSize where @@ -315,7 +358,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. windowTitle :: Window -> StateVar Text windowTitle (Window w) = makeStateVar getWindowTitle setWindowTitle where @@ -339,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 @@ -349,16 +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 - , windowVisible = wFlags .&. Raw.SDL_WINDOW_SHOWN > 0 + 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. @@ -388,13 +432,13 @@ -- | Hide a window. -- --- See @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. raiseWindow :: MonadIO m => Window -> m () raiseWindow (Window w) = Raw.raiseWindow w @@ -411,7 +455,7 @@ -- | Show a window. -- --- See @@ for C documentation. +-- See @@ for C documentation. showWindow :: MonadIO m => Window -> m () showWindow (Window w) = Raw.showWindow w @@ -538,7 +582,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. windowMaximumSize :: Window -> StateVar (V2 CInt) windowMaximumSize (Window win) = makeStateVar getWindowMaximumSize setWindowMaximumSize where @@ -555,7 +599,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. windowMinimumSize :: Window -> StateVar (V2 CInt) windowMinimumSize (Window win) = makeStateVar getWindowMinimumSize setWindowMinimumSize where @@ -568,6 +612,22 @@ 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 @@ and @@ 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 $ @@ -576,7 +636,7 @@ -- | Create a 2D software rendering context for the given surface. -- --- See @@ +-- See @@ createSoftwareRenderer :: MonadIO m => Surface -> m Renderer createSoftwareRenderer (Surface ptr _) = liftIO . fmap Renderer $ diff --git a/src/SDL/Video/OpenGL.hs b/src/SDL/Video/OpenGL.hs --- a/src/SDL/Video/OpenGL.hs +++ b/src/SDL/Video/OpenGL.hs @@ -103,7 +103,7 @@ -- Throws 'SDLException' if the window wasn't configured with OpenGL -- support, or if context creation fails. -- --- See @@ for C documentation. +-- See @@ for C documentation. glCreateContext :: (Functor m, MonadIO m) => Window -> m GLContext glCreateContext (Window w) = GLContext <$> throwIfNull "SDL.Video.glCreateContext" "SDL_GL_CreateContext" @@ -113,7 +113,7 @@ -- -- Throws 'SDLException' on failure. -- --- See @@ for C documentation. +-- See @@ for C documentation. glMakeCurrent :: (Functor m, MonadIO m) => Window -> GLContext -> m () glMakeCurrent (Window w) (GLContext ctx) = throwIfNeg_ "SDL.Video.OpenGL.glMakeCurrent" "SDL_GL_MakeCurrent" $ @@ -128,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 @@ for C documentation. +-- See @@ for C documentation. glDeleteContext :: MonadIO m => GLContext -> m () glDeleteContext (GLContext ctx) = Raw.glDeleteContext ctx @@ -136,7 +136,7 @@ -- contents of the back buffer are undefined, clear them with @glClear@ or -- equivalent before drawing to them again. -- --- See @@ for C documentation. +-- See @@ for C documentation. glSwapWindow :: MonadIO m => Window -> m () glSwapWindow (Window w) = Raw.glSwapWindow w @@ -167,7 +167,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. swapInterval :: StateVar SwapInterval swapInterval = makeStateVar glGetSwapInterval glSetSwapInterval where diff --git a/src/SDL/Video/Renderer.hs b/src/SDL/Video/Renderer.hs --- a/src/SDL/Video/Renderer.hs +++ b/src/SDL/Video/Renderer.hs @@ -7,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. @@ -31,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 @@ -40,6 +56,7 @@ , rendererDrawColor , rendererRenderTarget , rendererClipRect + , rendererIntegerScale , rendererLogicalSize , rendererScale , rendererViewport @@ -78,7 +95,7 @@ , paletteColors , paletteColor , PixelFormat(..) - , SurfacePixelFormat + , SurfacePixelFormat(..) , formatPalette , setPaletteColors , pixelFormatToMasks @@ -101,6 +118,10 @@ , textureBlendMode , BlendMode(..) , textureColorMod +#ifdef RECENT_ISH + , textureScaleMode + , ScaleMode(..) +#endif -- ** Accessing 'Texture' Data , lockTexture @@ -118,8 +139,8 @@ , getRenderDriverInfo ) where +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Exception (catch, throw, SomeException, uninterruptibleMask_) import Data.Bits import Data.Data (Data) import Data.Foldable @@ -143,8 +164,11 @@ 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) @@ -154,7 +178,7 @@ -- | Perform a fast surface copy to a destination surface. -- --- See @@ for C documentation. +-- See @@ 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 @@ -170,7 +194,7 @@ -- | Create a texture for a rendering context. -- --- See @@ for C documentation. +-- See @@ for C documentation. createTexture :: (Functor m,MonadIO m) => Renderer -- ^ The rendering context. -> PixelFormat @@ -184,7 +208,7 @@ -- | Create a texture from an existing surface. -- --- See @@ for C documentation. +-- See @@ for C documentation. createTextureFromSurface :: (Functor m,MonadIO m) => Renderer -- ^ The rendering context -> Surface -- ^ The surface containing pixel data used to fill the texture @@ -196,7 +220,7 @@ -- | Bind an OpenGL\/ES\/ES2 texture to the current context for use with when rendering OpenGL primitives directly. -- --- See @@ for C documentation. +-- See @@ for C documentation. glBindTexture :: (Functor m,MonadIO m) => Texture -- ^ The texture to bind to the current OpenGL\/ES\/ES2 context -> m () @@ -206,7 +230,7 @@ -- | Unbind an OpenGL\/ES\/ES2 texture from the current context. -- --- See @@ for C documentation. +-- See @@ for C documentation. glUnbindTexture :: (Functor m,MonadIO m) => Texture -- ^ The texture to unbind from the current OpenGL\/ES\/ES2 context -> m () @@ -216,30 +240,29 @@ -- | Updates texture rectangle with new pixel data. -- --- See @@ for C documentation. +-- See @@ 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 @@ for the C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ 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 @@ -258,13 +281,13 @@ -- -- /Warning/: See before using this function! -- --- See @@ for C documentation. +-- See @@ for C documentation. unlockTexture :: MonadIO m => Texture -> m () unlockTexture (Texture t) = Raw.unlockTexture t -- | Set up a surface for directly accessing the pixels. -- --- See @@ for C documentation. +-- See @@ for C documentation. lockSurface :: MonadIO m => Surface -> m () lockSurface (Surface s _) = throwIfNeg_ "lockSurface" "SDL_LockSurface" $ @@ -272,7 +295,7 @@ -- | Release a surface after directly accessing the pixels. -- --- See @@ for C documentation. +-- See @@ for C documentation. unlockSurface :: MonadIO m => Surface -> m () unlockSurface (Surface s _) = Raw.unlockSurface s @@ -312,7 +335,7 @@ -- | Query the attributes of a texture. -- --- See @@ for C documentation. +-- See @@ for C documentation. queryTexture :: MonadIO m => Texture -> m TextureInfo queryTexture (Texture tex) = liftIO $ alloca $ \pfPtr -> @@ -329,7 +352,7 @@ -- | Allocate a new RGB surface. -- --- See @@ for C documentation. +-- See @@ 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 @@ -342,7 +365,7 @@ -- | Allocate a new RGB surface with existing pixel data. -- --- See @@ for C documentation. +-- See @@ for C documentation. createRGBSurfaceFrom :: (Functor m, MonadIO m) => MSV.IOVector Word8 -- ^ The existing pixel data -> V2 CInt -- ^ The size of the surface @@ -360,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 @@ for C documentation. +-- See @@ 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. @@ -376,7 +399,7 @@ -- -- 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 @@ for C documentation. +-- See @@ 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. @@ -395,13 +418,13 @@ -- -- If the surface was created using 'createRGBSurfaceFrom' then the pixel data is not freed. -- --- See @@ for the C documentation. +-- See @@ for the C documentation. freeSurface :: MonadIO m => Surface -> m () freeSurface (Surface s _) = Raw.freeSurface s -- | Load a surface from a BMP file. -- --- See @@ for C documentation. +-- See @@ for C documentation. loadBMP :: MonadIO m => FilePath -> m Surface loadBMP filePath = liftIO $ fmap unmanagedSurface $ @@ -462,7 +485,7 @@ -- | Set a range of colors in a palette. -- --- See @@ for C documentation. +-- See @@ 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 @@ -477,7 +500,7 @@ -- | Get the SDL surface associated with the window. -- --- See @@ for C documentation. +-- See @@ for C documentation. getWindowSurface :: (Functor m, MonadIO m) => Window -> m Surface getWindowSurface (Window w) = fmap unmanagedSurface $ @@ -488,11 +511,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -506,11 +529,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. rendererDrawColor :: Renderer -> StateVar (V4 Word8) rendererDrawColor (Renderer re) = makeStateVar getRenderDrawColor setRenderDrawColor where - getRenderDrawColor = liftIO $ + getRenderDrawColor = alloca $ \r -> alloca $ \g -> alloca $ \b -> @@ -527,7 +550,7 @@ -- -- This is the function you use to reflect any changes to the surface on the screen. -- --- See @@ for C documentation. +-- See @@ for C documentation. updateWindowSurface :: (Functor m, MonadIO m) => Window -> m () updateWindowSurface (Window w) = throwIfNeg_ "SDL.Video.updateWindowSurface" "SDL_UpdateWindowSurface" $ @@ -579,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)) @@ -588,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) @@ -602,7 +660,7 @@ -- | Draw a rectangle outline on the current rendering target. -- --- See @@ for C documentation. +-- See @@ for C documentation. drawRect :: MonadIO m => Renderer -> Maybe (Rectangle CInt) -- ^ The rectangle outline to draw. 'Nothing' for the entire rendering context. @@ -613,7 +671,7 @@ -- | Draw some number of rectangles on the current rendering target. -- --- See @@ for C documentation. +-- See @@ for C documentation. drawRects :: MonadIO m => Renderer -> SV.Vector (Rectangle CInt) -> m () drawRects (Renderer r) rects = liftIO $ throwIfNeg_ "SDL.Video.drawRects" "SDL_RenderDrawRects" $ @@ -624,7 +682,7 @@ -- | Fill a rectangle on the current rendering target with the drawing color. -- --- See @@ for C documentation. +-- See @@ for C documentation. fillRect :: MonadIO m => Renderer @@ -640,7 +698,7 @@ -- | Fill some number of rectangles on the current rendering target with the drawing color. -- --- See @@ for C documentation. +-- See @@ for C documentation. fillRects :: MonadIO m => Renderer -> SV.Vector (Rectangle CInt) -> m () fillRects (Renderer r) rects = liftIO $ throwIfNeg_ "SDL.Video.fillRects" "SDL_RenderFillRects" $ @@ -649,9 +707,136 @@ (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 @@ for C documentation. +-- See @@ for C documentation. clear :: (Functor m, MonadIO m) => Renderer -> m () clear (Renderer r) = throwIfNeg_ "SDL.Video.clear" "SDL_RenderClear" $ @@ -664,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 @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. rendererScale :: Renderer -> StateVar (V2 CFloat) rendererScale (Renderer r) = makeStateVar renderGetScale renderSetScale where @@ -672,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 @@ -682,16 +867,15 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -699,17 +883,16 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -721,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 @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. copy :: MonadIO m => Renderer -- ^ The rendering context -> Texture -- ^ The source texture @@ -743,7 +926,7 @@ -- | 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 @@ for C documentation. +-- See @@ for C documentation. copyEx :: MonadIO m => Renderer -- ^ The rendering context -> Texture -- ^ The source texture @@ -766,7 +949,7 @@ -- | Draw a line on the current rendering target. -- --- See @@ for C documentation. +-- See @@ for C documentation. drawLine :: (Functor m,MonadIO m) => Renderer -> Point V2 CInt -- ^ The start point of the line @@ -778,7 +961,7 @@ -- | Draw a series of connected lines on the current rendering target. -- --- See @@ for C documentation. +-- See @@ 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. @@ -793,7 +976,7 @@ -- | Draw a point on the current rendering target. -- --- See @@ for C documentation. +-- See @@ 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" $ @@ -801,7 +984,7 @@ -- | Draw multiple points on the current rendering target. -- --- See @@ for C documentation. +-- See @@ for C documentation. drawPoints :: MonadIO m => Renderer -> SV.Vector (Point V2 CInt) -> m () drawPoints (Renderer r) points = liftIO $ @@ -815,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 @@ for C documentation. +-- See @@ for C documentation. convertSurface :: (Functor m,MonadIO m) => Surface -- ^ The 'Surface' to convert -> SurfacePixelFormat -- ^ The pixel format that the new surface is optimized for @@ -827,7 +1010,7 @@ -- | Perform a scaled surface copy to a destination surface. -- --- See @@ for C documentation. +-- See @@ 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 @@ -845,12 +1028,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -864,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 -> @@ -886,11 +1067,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -903,7 +1084,7 @@ Raw.setTextureColorMod t r g b data PixelFormat - = Unknown + = Unknown !Word32 | Index1LSB | Index1MSB | Index4LSB @@ -939,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 @@ -979,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 @@ -1101,7 +1282,7 @@ -- | Get information about a rendering context. -- --- See @@ for C documentation. +-- See @@ for C documentation. getRendererInfo :: MonadIO m => Renderer -> m RendererInfo getRendererInfo (Renderer renderer) = liftIO $ alloca $ \rptr -> do @@ -1111,7 +1292,7 @@ -- | Enumerate all known render drivers on the system, and determine their supported features. -- --- See @@ for C documentation. +-- See @@ for C documentation. getRenderDriverInfo :: MonadIO m => m [RendererInfo] getRenderDriverInfo = liftIO $ do count <- Raw.getNumRenderDrivers @@ -1126,11 +1307,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -1144,11 +1325,11 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -1158,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 : 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 @@ and @@ +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 @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ -1180,7 +1406,7 @@ -- -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- --- See @@ and @@ for C documentation. +-- See @@ and @@ for C documentation. rendererRenderTarget :: Renderer -> StateVar (Maybe Texture) rendererRenderTarget (Renderer r) = makeStateVar getRenderTarget setRenderTarget where @@ -1197,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 @@ and @@ for C documentation. +-- See @@ and @@ 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 @@ and @@ 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 @@ -1220,13 +1463,13 @@ -- | Determine whether a window supports the use of render targets. -- --- See @@ for C documentation. +-- See @@ 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 @@ for C documentation. +-- See @@ for C documentation. pixelFormatToMasks :: (MonadIO m) => PixelFormat -> m (CInt, V4 Word32) pixelFormatToMasks pf = liftIO $ alloca $ \bpp -> @@ -1242,7 +1485,7 @@ -- | Convert a bpp value and RGBA masks to an enumerated pixel format. -- --- See @@ for C documentation. +-- See @@ 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 diff --git a/src/SDL/Video/Vulkan.hs b/src/SDL/Video/Vulkan.hs new file mode 100644 --- /dev/null +++ b/src/SDL/Video/Vulkan.hs @@ -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 ). +-- +-- 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 ), +-- 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