Fix event polling

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
@@ -765,11 +766,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 ++) <$> peepAllEvents
+        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 #-}