Fix event polling

pollEvents was apparently broken by a recent-ish
[patch](libsdl-org/SDL#4794) to SDL.

This should fix that. As an aside, this attempts to make polling events
a bit more efficient; We just statically allocate a single buffer for
events (AFAIK you can only call Poll from the main thread anyway, so the
fact that this isn't thread safe shouldn't be an issue).

Author: hanst99

cbits/sdlhelper.c

@@ -1,6 +1,17 @@
 #include <string.h>
+#include <stdlib.h>
 #include "sdlhelper.h"
 
+int SDLHelper_GetEventBufferSize() { return 64; }
+SDL_Event *SDLHelper_GetEventBuffer() {
+  static SDL_Event *buffer = NULL;
+  if(buffer == NULL) {
+    /* leak an inconsequental amount of memory */
+    buffer = calloc(SDLHelper_GetEventBufferSize(), sizeof(SDL_Event));
+  }
+  return buffer;
+}
+
 void SDLHelper_JoystickGetDeviceGUID (int device_index, SDL_JoystickGUID *guid)
 {
   SDL_JoystickGUID t = SDL_JoystickGetDeviceGUID (device_index);

include/sdlhelper.h

@@ -4,6 +4,8 @@
 #include <stddef.h>
 #include "SDL.h"
 
+int SDLHelper_GetEventBufferSize(void);
+SDL_Event *SDLHelper_GetEventBuffer(void);
 void SDLHelper_JoystickGetDeviceGUID (int device_index, SDL_JoystickGUID *guid);
 void SDLHelper_JoystickGetGUID (SDL_Joystick *joystick, SDL_JoystickGUID *guid);
 void SDLHelper_JoystickGetGUIDFromString (const char *pchGUID, SDL_JoystickGUID *guid);

src/SDL/Event.hs

@@ -92,6 +92,7 @@ import Data.Text (Text)
 import Data.Typeable
 import Foreign hiding (throwIfNeg_)
 import Foreign.C
+import Foreign.Marshal.Array
 import GHC.Generics (Generic)
 import SDL.Vect
 import SDL.Input.Joystick
@@ -104,6 +105,7 @@ import SDL.Internal.Types (Window(Window))
 import qualified Data.ByteString.Char8 as BSC8
 import qualified Data.Text.Encoding as Text
 import qualified SDL.Raw as Raw
+import Text.Printf
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
@@ -765,11 +767,20 @@ pollEvent =
 -- Like 'pollEvent' this function should only be called in the OS thread which
 -- set the video mode.
 pollEvents :: MonadIO m => m [Event]
-pollEvents =
-  do e <- pollEvent
-     case e of
-       Nothing -> return []
-       Just e' -> (e' :) <$> pollEvents
+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 ++) <$> peepAllEvnets
+        else return peeped
 
 -- | Run a monadic computation, accumulating over all known 'Event's.
 --

src/SDL/Raw/Event.hs

@@ -112,7 +112,9 @@ module SDL.Raw.Event (
   gameControllerNameForIndex,
   gameControllerOpen,
   gameControllerUpdate,
-  isGameController
+  isGameController,
+  eventBuffer,
+  eventBufferSize
 ) where
 
 import Control.Monad.IO.Class
@@ -235,6 +237,9 @@ foreign import ccall "SDL.h SDL_GameControllerOpen" gameControllerOpenFFI :: CIn
 foreign import ccall "SDL.h SDL_GameControllerUpdate" gameControllerUpdateFFI :: 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 #-}