sdl2 2.4.0.1 → 2.4.1.0

raw patch · 9 files changed

+418/−15 lines, 9 filesdep +deepseqdep +weighdep ~basedep ~lineardep ~vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, weigh

Dependency ranges changed: base, linear, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• bench/Space.hs +337/−0
• cbits/sdlhelper.c +10/−0
• sdl2.cabal +16/−1
• src/SDL/Event.hs +12/−5
• src/SDL/Input/Mouse.hs +1/−1
• src/SDL/Internal/Exception.hs +8/−0
• src/SDL/Raw/Video.hs +6/−0
• src/SDL/Video/Renderer.hs +14/−8

@@ -1,3 +1,17 @@+2.4.1.0+=======++* More SDL functions no longer allocate. See+  https://github.com/haskell-game/sdl2/pull/179 and+  https://github.com/haskell-game/sdl2/issues/178. Thanks to @chrisdone for this+  work.+++* Fixed an off-by-one bug in `SDL.Input.Mouse.getMouseButtons`. See+  https://github.com/haskell-game/sdl2/pull/177 for more information. Thanks to+  @Linearity for identifying and fixing this bug.++         2.4.0.1 ======= * Raise upper bounds for `exceptions` to <0.11

@@ -0,0 +1,337 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Test that space usage is low and avoid GCs where possible.++module Main where++import qualified Data.Vector.Storable as SV+import qualified Data.Vector.Storable.Mutable as SVM+import           Foreign.C (CInt)+import           Foreign.Ptr+import           Foreign.Storable+import           SDL+import           Weigh++-- | Main entry point.+main :: IO ()+main =+  mainWith+    (do setColumns [Case, Allocated, GCs]+        wgroup+          "pollEvent"+          (sequence_+             [ validateAction+               ("pollEvent " ++ show i)+               pollEventTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 2000+                           then Just+                                  "Allocated >2KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000, 10000]+             ])+        wgroup+          "pollEvent+clear"+          (sequence_+             [ validateAction+               ("pollEvent + clear " ++ show i)+               pollEventClearTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 3000+                           then Just+                                  "Allocated >3KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000, 10000]+             ])+        wgroup+          "pollEvent+present"+          (sequence_+             [ validateAction+               ("pollEvent + present " ++ show i)+               pollEventPresentTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 4000+                           then Just+                                  "Allocated >4KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000]+             ])+        wgroup+          "pollEvent+drawColor"+          (sequence_+             [ validateAction+               ("pollEvent + drawColor " ++ show i)+               pollEventDrawColorTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 4000+                           then Just+                                  "Allocated >KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000, 2000]+             ])+        wgroup+          "pollEvent+drawRect"+          (sequence_+             [ validateAction+               ("pollEvent + drawRect " ++ show i)+               pollEventDrawRectTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 4000+                           then Just+                                  "Allocated >4KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000]+             ])+        wgroup+          "animated rect"+          (sequence_+             [ validateAction+               ("animated rect " ++ show i)+               pollEventAnimRectTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 4000+                           then Just+                                  "Allocated >4KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000, 2000]+             ])+        wgroup+          "animated rects"+          (sequence_+             [ validateAction+               ("animated rects " ++ show i)+               pollEventAnimRectsTest+               i+               (\weight ->+                  if weightGCs weight > 0+                    then Just "Non-zero number of garbage collections!"+                    else if weightAllocatedBytes weight > 5000+                           then Just+                                  "Allocated >4KB! Allocations should be constant."+                           else Nothing)+             | i <- [1, 10, 100, 1000, 2000, 3000]+             ]))++-- | Test that merely polling does not allocate or engage the GC.+-- <https://github.com/haskell-game/sdl2/issues/178>+pollEventTest :: Int -> IO ()+pollEventTest iters = do+  initializeAll+  let go :: Int -> IO ()+      go 0 = pure ()+      go i = do+        _ <- pollEvent+        go (i - 1)+  go iters++-- | Test that merely polling and clearing the screen does not+-- allocate or engage the GC.+pollEventClearTest :: Int -> IO ()+pollEventClearTest iters = do+  initializeAll+  window <- createWindow "pollEventClearTest" defaultWindow+  renderer <- createRenderer window (-1) defaultRenderer+  let go :: Int -> IO ()+      go 0 = pure ()+      go i = do+        _ <- pollEvent+        clear renderer+        go (i - 1)+  go iters++-- | Test that merely polling and presenting does not allocate or+-- engage the GC.+pollEventPresentTest :: Int -> IO ()+pollEventPresentTest iters = do+  initializeAll+  window <- createWindow "pollEventPresentTest" defaultWindow+  renderer <- createRenderer window (-1) defaultRenderer+  let go :: Int -> IO ()+      go 0 = pure ()+      go i = do+        _ <- pollEvent+        clear renderer+        present renderer+        go (i - 1)+  go iters++-- | Test that merely polling and drawColoring does not allocate or+-- engage the GC.+pollEventDrawColorTest :: Int -> IO ()+pollEventDrawColorTest iters = do+  initializeAll+  window <- createWindow "pollEventDrawColorTest" defaultWindow+  renderer <- createRenderer window (-1) defaultRenderer+  let go :: Int -> IO ()+      go 0 = pure ()+      go i = do+        _ <- pollEvent+        rendererDrawColor renderer $= V4 0 0 255 255+        clear renderer+        present renderer+        go (i - 1)+  go iters++-- | Draw a rectangle on screen.+pollEventDrawRectTest :: Int -> IO ()+pollEventDrawRectTest iters = do+  initializeAll+  window <- createWindow "pollEventDrawRectTest" defaultWindow+  renderer <- createRenderer window (-1) defaultRenderer+  let go :: Int -> IO ()+      go 0 = pure ()+      go i = do+        _ <- pollEvent+        rendererDrawColor renderer $= V4 40 40 40 255+        clear renderer+        rendererDrawColor renderer $= V4 255 255 255 255+        fillRect renderer (Just (Rectangle (P (V2 40 40)) (V2 80 80)))+        present renderer+        go (i - 1)+  go iters++--------------------------------------------------------------------------------+-- Animated rect test++data State = State+  { stateI :: !CInt+  , stateV :: !(V2 CInt)+  , stateP :: !(V2 CInt)+  }++-- | Animate a rectangle on the screen for n iterations.+pollEventAnimRectTest :: CInt -> IO ()+pollEventAnimRectTest iters = do+  initializeAll+  window <-+    createWindow+      "pollEventAnimRectTest"+      defaultWindow {windowInitialSize = defaultWindowSize}+  renderer <- createRenderer window (-1) defaultRenderer+  let go ::  State -> IO ()+      go !(State 0 _ _) = pure ()+      go !(State i (V2 xv yv) p@(V2 x y)) = do+        _ <- pollEvent+        rendererDrawColor renderer $= V4 40 40 40 255+        clear renderer+        rendererDrawColor renderer $= V4 255 255 255 255+        let xv'+              | x + w > mw = -xv+              | x < 0 = -xv+              | otherwise = xv+            yv'+              | y + h > mh = -yv+              | y < 0 = -yv+              | otherwise = yv+            v' = V2 xv' yv'+            p' = p + v'+        fillRect renderer (Just (Rectangle (P p') (V2 w h)))+        present renderer+        go (State (i - 1) v' p')+  go (State iters (V2 2 1) (V2 0 0))+  where+    defaultWindowSize :: V2 CInt+    defaultWindowSize = V2 800 600+    mw :: CInt+    mh :: CInt+    V2 mw mh = defaultWindowSize+    w :: CInt+    h :: CInt+    (w, h) = (100, 100)++--------------------------------------------------------------------------------+-- Animated rects test++data Square = Square+  {  squareV :: !(V2 CInt)+   , squareP :: !(V2 CInt)+  }++instance Storable Square where+  sizeOf _ = sizeOf (undefined :: V2 CInt) * 2+  alignment _ = 1+  poke  ptr (Square x y) = do+    poke (castPtr ptr) x+    poke (plusPtr ptr (sizeOf x)) y+  peek ptr = do+    x <- peek (castPtr ptr)+    y <- peek (plusPtr ptr (sizeOf x))+    pure (Square x y)++-- | Animate a rectangle on the screen for n iterations.+pollEventAnimRectsTest :: CInt -> IO ()+pollEventAnimRectsTest iters = do+  initializeAll+  window <-+    createWindow+      "pollEventAnimRectsTest"+      defaultWindow {windowInitialSize = defaultWindowSize}+  renderer <- createRenderer window (-1) defaultRenderer+  squares <-+    SV.unsafeThaw+      (SV.fromList+         [ Square (V2 2 1) (V2 0 0)+         , Square (V2 3 2) (V2 300 200)+         , Square (V2 1 1) (V2 100 500)+         , Square (V2 1 1) (V2 400 100)+         , Square (V2 1 2) (V2 200 400)+         , Square (V2 2 1) (V2 250 0)+         , Square (V2 1 2) (V2 300 500)+         , Square (V2 1 2) (V2 230 100)+         , Square (V2 1 1) (V2 200 490)+         ])+  let go :: CInt -> IO ()+      go !0 = pure ()+      go !i = do+        _ <- pollEvent+        rendererDrawColor renderer $= V4 40 40 40 255+        clear renderer+        rendererDrawColor renderer $= V4 255 255 255 255+        let animateSquare si = do+              Square (V2 xv yv) p@(V2 x y) <- SVM.read squares si+              let xv'+                    | x + w > mw = -xv+                    | x < 0 = -xv+                    | otherwise = xv+                  yv'+                    | y + h > mh = -yv+                    | y < 0 = -yv+                    | otherwise = yv+                  v' = V2 xv' yv'+                  p' = p + v'+              SVM.write squares si (Square v' p')+              fillRect renderer (Just (Rectangle (P p') (V2 w h)))+        let loop 0 = pure ()+            loop si = animateSquare si>>loop (si-1)+        loop (SVM.length squares - 1)+        present renderer+        go (i - 1)+  go iters+  where+    defaultWindowSize :: V2 CInt+    defaultWindowSize = V2 800 600+    mw :: CInt+    mh :: CInt+    V2 mw mh = defaultWindowSize+    w :: CInt+    h :: CInt+    (w, h) = (100, 100)

@@ -75,3 +75,13 @@ {   return SDL_SetError ("%s", str); }++int SDLHelper_RenderFillRectEx(SDL_Renderer*   renderer, int x, int y, int w, int h)+{+  SDL_Rect rect;+  rect.x=x;+  rect.y=y;+  rect.w=w;+  rect.h=h;+  return SDL_RenderFillRect(renderer,&rect);+}

@@ -1,5 +1,5 @@ name:                sdl2-version:             2.4.0.1+version:             2.4.1.0 synopsis:            Both high- and low-level bindings to the SDL library (version 2.0.4+). description:   This package contains bindings to the SDL 2 library, in both high- and@@ -12,6 +12,8 @@   Haskell FFI calls. As such, this does not contain sum types nor error   checking. Thus this namespace is suitable for building your own abstraction   over SDL, but is not recommended for day-to-day programming.+  .+  Read "SDL" for a getting started guide.  license:             BSD3 license-file:        LICENSE@@ -139,6 +141,19 @@    if os(windows)     cpp-options: -D_SDL_main_h -DSDL_main_h_++test-suite sdl-space+  type:                exitcode-stdio-1.0+  main-is:             Space.hs+  hs-source-dirs:      bench+  build-depends:       base+                     , weigh >= 0.0.8+                     , linear+                     , sdl2+                     , deepseq+                     , vector+  ghc-options:         -Wall -rtsopts -O2+  default-language:    Haskell2010  executable lazyfoo-lesson-01   if flag(examples)

@@ -746,11 +746,18 @@  -- | Poll for currently pending events. You can only call this function in the thread that set the video mode. pollEvent :: MonadIO m => m (Maybe Event)-pollEvent = liftIO $ alloca $ \e -> do-  n <- Raw.pollEvent e-  if n == 0-     then return Nothing-     else fmap Just (peek e >>= convertRaw)+pollEvent =+  liftIO $ do+    n <- Raw.pollEvent nullPtr+    -- We use NULL first to check if there's an event.+    if n == 0+      then return Nothing+      else alloca $ \e -> do+             n <- Raw.pollEvent e+             -- Checking 0 again doesn't hurt and it's good to be safe.+             if n == 0+               then return Nothing+               else fmap Just (peek e >>= convertRaw)  -- | Clear the event queue by polling for all pending events. pollEvents :: (Functor m, MonadIO m) => m [Event]

@@ -203,7 +203,7 @@ getMouseButtons = liftIO $   convert <$> Raw.getMouseState nullPtr nullPtr   where-    convert w b = w `testBit` fromIntegral (toNumber b)+    convert w b = w `testBit` fromIntegral (toNumber b - 1)  newtype Cursor = Cursor { unwrapCursor :: Raw.Cursor }     deriving (Eq, Typeable)

@@ -33,6 +33,7 @@   cstr <- Raw.getError   Text.decodeUtf8 <$> BS.packCString cstr +{-# INLINE throwIf #-} throwIf :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m a throwIf f caller funName m = do   a <- m@@ -40,24 +41,31 @@     (SDLCallFailed caller funName <$> getError) >>= throwIO   return a +{-# INLINE throwIf_ #-} throwIf_ :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m () throwIf_ f caller funName m = throwIf f caller funName m >> return () +{-# INLINE throwIfNeg #-} throwIfNeg :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m a throwIfNeg = throwIf (< 0) +{-# INLINE throwIfNeg_ #-} throwIfNeg_ :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m () throwIfNeg_ = throwIf_ (< 0) +{-# INLINE throwIfNull #-} throwIfNull :: (MonadIO m) => Text -> Text -> m (Ptr a) -> m (Ptr a) throwIfNull = throwIf (== nullPtr) +{-# INLINE throwIf0 #-} throwIf0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a throwIf0 = throwIf (== 0) +{-# INLINE throwIfNot0 #-} throwIfNot0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a throwIfNot0 = throwIf (/= 0) +{-# INLINE throwIfNot0_ #-} throwIfNot0_ :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m () throwIfNot0_ = throwIf_ (/= 0) 

@@ -110,6 +110,7 @@   renderDrawRect,   renderDrawRects,   renderFillRect,+  renderFillRectEx,   renderFillRects,   renderGetClipRect,   renderGetLogicalSize,@@ -315,6 +316,7 @@ 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+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_RenderGetLogicalSize" renderGetLogicalSizeFFI :: Renderer -> Ptr CInt -> Ptr CInt -> IO ()@@ -821,6 +823,10 @@ renderDrawRects :: MonadIO m => Renderer -> Ptr Rect -> CInt -> m CInt renderDrawRects v1 v2 v3 = liftIO $ renderDrawRectsFFI v1 v2 v3 {-# INLINE renderDrawRects #-}++renderFillRectEx :: MonadIO m => Renderer -> CInt -> CInt -> CInt -> CInt -> m CInt+renderFillRectEx v1 x y w h = liftIO $ renderFillRectExFFI v1 x y w h+{-# INLINE renderFillRectEx #-}  renderFillRect :: MonadIO m => Renderer -> Ptr Rect -> m CInt renderFillRect v1 v2 = liftIO $ renderFillRectFFI v1 v2

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}@@ -118,6 +119,7 @@   ) where  import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Exception (catch, throw, SomeException, uninterruptibleMask_) import Data.Bits import Data.Data (Data) import Data.Foldable@@ -623,15 +625,18 @@ -- | Fill a rectangle on the current rendering target with the drawing color. -- -- See @<https://wiki.libsdl.org/SDL_RenderFillRect SDL_RenderFillRect>@ for C documentation.-fillRect :: MonadIO m-         => Renderer-         -> Maybe (Rectangle CInt) -- ^ The rectangle to fill. 'Nothing' for the entire rendering context.-         -> m ()-fillRect (Renderer r) rect = liftIO $ do+fillRect ::+     MonadIO m+  => Renderer+  -> Maybe (Rectangle CInt) -- ^ The rectangle to fill.+  -> m ()+fillRect (Renderer r) rect =+  liftIO $   throwIfNeg_ "SDL.Video.fillRect" "SDL_RenderFillRect" $-    maybeWith with rect $ \rPtr ->-      Raw.renderFillRect r-                         (castPtr rPtr)+  case rect of+    Nothing -> Raw.renderFillRect r nullPtr+    Just (Rectangle (P (V2 x y)) (V2 w h)) -> Raw.renderFillRectEx r x y w h+{-# INLINE fillRect #-}  -- | Fill some number of rectangles on the current rendering target with the drawing color. --@@ -651,6 +656,7 @@ clear (Renderer r) =   throwIfNeg_ "SDL.Video.clear" "SDL_RenderClear" $   Raw.renderClear r+{-# INLINE clear #-}  -- | Get or set the drawing scale for rendering on the current target. --