Add support for SDL_RenderSetIntegerScale

ChangeLog.md

@@ -1,3 +1,8 @@
+2.5.X.Y
+=======
+
+* Added `rendererIntegerScale`
+
 2.5.5.0
 =======
 

src/SDL/Raw/Video.hs

@@ -134,13 +134,15 @@ module SDL.Raw.Video (
   renderGeometryRaw,
 #endif
   renderGetClipRect,
+  renderGetIntegerScale,
   renderGetLogicalSize,
   renderGetScale,
   renderGetViewport,
   renderIsClipEnabled,
   renderPresent,
   renderReadPixels,
   renderSetClipRect,
+  renderSetIntegerScale,
   renderSetLogicalSize,
   renderSetScale,
   renderSetViewport,
@@ -367,13 +369,15 @@ foreign import ccall "SDL.h SDL_RenderGeometryRaw" renderGeometryRawFFI :: Rende
 foreign import ccall "sqlhelper.c SDLHelper_RenderFillRectEx" renderFillRectExFFI :: Renderer -> CInt -> CInt -> CInt -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderFillRects" renderFillRectsFFI :: Renderer -> Ptr Rect -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderGetClipRect" renderGetClipRectFFI :: Renderer -> Ptr Rect -> IO ()
+foreign import ccall "SDL.h SDL_RenderGetIntegerScale" renderGetIntegerScaleFFI :: Renderer -> IO CInt
 foreign import ccall "SDL.h SDL_RenderGetLogicalSize" renderGetLogicalSizeFFI :: Renderer -> Ptr CInt -> Ptr CInt -> IO ()
 foreign import ccall "SDL.h SDL_RenderGetScale" renderGetScaleFFI :: Renderer -> Ptr CFloat -> Ptr CFloat -> IO ()
 foreign import ccall "SDL.h SDL_RenderGetViewport" renderGetViewportFFI :: Renderer -> Ptr Rect -> IO ()
 foreign import ccall "SDL.h SDL_RenderIsClipEnabled" renderIsClipEnabledFFI :: Renderer -> IO Bool
 foreign import ccall "SDL.h SDL_RenderPresent" renderPresentFFI :: Renderer -> IO ()
 foreign import ccall "SDL.h SDL_RenderReadPixels" renderReadPixelsFFI :: Renderer -> Ptr Rect -> Word32 -> Ptr () -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderSetClipRect" renderSetClipRectFFI :: Renderer -> Ptr Rect -> IO CInt
+foreign import ccall "SDL.h SDL_RenderSetIntegerScale" renderSetIntegerScaleFFI :: Renderer -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderSetLogicalSize" renderSetLogicalSizeFFI :: Renderer -> CInt -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderSetScale" renderSetScaleFFI :: Renderer -> CFloat -> CFloat -> IO CInt
 foreign import ccall "SDL.h SDL_RenderSetViewport" renderSetViewportFFI :: Renderer -> Ptr Rect -> IO CInt
@@ -967,6 +971,10 @@ 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 #-}
@@ -995,6 +1003,10 @@ renderSetClipRect :: MonadIO m => Renderer -> Ptr Rect -> m CInt
 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 #-}

src/SDL/Video/Renderer.hs

@@ -55,6 +55,7 @@ module SDL.Video.Renderer
   , rendererDrawColor
   , rendererRenderTarget
   , rendererClipRect
+  , rendererIntegerScale
   , rendererLogicalSize
   , rendererScale
   , rendererViewport
@@ -133,6 +134,7 @@ module SDL.Video.Renderer
   , getRenderDriverInfo
   ) where
 
+import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Bits
 import Data.Data (Data)
@@ -505,7 +507,7 @@ getWindowSurface (Window w) =
 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
@@ -523,7 +525,7 @@ rendererDrawBlendMode (Renderer r) = makeStateVar getRenderDrawBlendMode setRend
 rendererDrawColor :: Renderer -> StateVar (V4 Word8)
 rendererDrawColor (Renderer re) = makeStateVar getRenderDrawColor setRenderDrawColor
   where
-  getRenderDrawColor = liftIO $
+  getRenderDrawColor =
     alloca $ \r ->
     alloca $ \g ->
     alloca $ \b ->
@@ -812,7 +814,7 @@ rendererScale (Renderer r) = makeStateVar renderGetScale renderSetScale
     throwIfNeg_ "SDL.Video.renderSetScale" "SDL_RenderSetScale" $
     Raw.renderSetScale r x y
 
-  renderGetScale = liftIO $
+  renderGetScale =
     alloca $ \w ->
     alloca $ \h -> do
       Raw.renderGetScale r w h
@@ -826,12 +828,11 @@ rendererScale (Renderer r) = makeStateVar renderGetScale renderSetScale
 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
 
@@ -843,13 +844,12 @@ rendererClipRect (Renderer r) = makeStateVar renderGetClipRect renderSetClipRect
 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
 
@@ -990,7 +990,6 @@ 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
@@ -1004,7 +1003,6 @@ surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey
                     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 ->
@@ -1030,7 +1028,7 @@ surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey
 textureColorMod :: Texture -> StateVar (V3 Word8)
 textureColorMod (Texture t) = makeStateVar getTextureColorMod setTextureColorMod
   where
-  getTextureColorMod = liftIO $
+  getTextureColorMod =
     alloca $ \r ->
     alloca $ \g ->
     alloca $ \b -> do
@@ -1270,7 +1268,7 @@ getRenderDriverInfo = liftIO $ do
 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
@@ -1288,7 +1286,7 @@ textureAlphaMod (Texture t) = makeStateVar getTextureAlphaMod setTextureAlphaMod
 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
@@ -1306,7 +1304,7 @@ textureBlendMode (Texture t) = makeStateVar getTextureBlendMode setTextureBlendM
 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
@@ -1337,15 +1335,32 @@ rendererRenderTarget (Renderer r) = makeStateVar getRenderTarget setRenderTarget
       Nothing -> Raw.setRenderTarget r nullPtr
       Just (Texture t) -> Raw.setRenderTarget r t
 
--- | Get or set the device independent resolution for rendering.
+-- | Get or set whether to force integer scales for resolution-independent rendering.
+-- It may be desirable to enable integer scales when using device independent resolution
+-- via 'rendererLogicalSize' so that pixel sizing is consistent.
+--
+-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'.
+--
+-- See @<https://wiki.libsdl.org/SDL_RenderSetIntegerScale SDL_RenderSetIntegerScale>@ and @<https://wiki.libsdl.org/SDL_RenderGetIntegerScale SDL_RenderGetIntegerScale>@ for C documentation.
+rendererIntegerScale :: Renderer -> StateVar Bool
+rendererIntegerScale (Renderer r) = makeStateVar renderGetIntegerScale renderSetIntegerScale
+  where
+  renderGetIntegerScale = (== 1) <$> Raw.renderGetIntegerScale r
+
+  renderSetIntegerScale True = void $ Raw.renderSetIntegerScale r 1
+  renderSetIntegerScale False = void $ Raw.renderSetIntegerScale r 0
+
+-- | Get or set the device independent resolution for rendering. When using this setting,
+-- it may be desirable to also enable integer scales via 'rendererIntegerScale' so that
+-- pixel sizing is consistent.
 --
 -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'.
 --
 -- See @<https://wiki.libsdl.org/SDL_RenderSetLogicalSize SDL_RenderSetLogicalSize>@ and @<https://wiki.libsdl.org/SDL_RenderGetLogicalSize SDL_RenderGetLogicalSize>@ for C documentation.
 rendererLogicalSize :: Renderer -> StateVar (Maybe (V2 CInt))
 rendererLogicalSize (Renderer r) = makeStateVar renderGetLogicalSize renderSetLogicalSize
   where
-  renderGetLogicalSize = liftIO $
+  renderGetLogicalSize =
     alloca $ \w -> do
     alloca $ \h -> do
       Raw.renderGetLogicalSize r w h