From 155fb748d1b2b6fa2ef1d111a549d330144ef197 Mon Sep 17 00:00:00 2001
From: Hannes Steffenhagen <LeExarmatio@gmail.com>
Date: Mon, 7 Feb 2022 19:06:52 +0100
Subject: [PATCH] Fix event polling

pollEvents was apparently broken by a recent-ish
[patch](https://github.com/libsdl-org/SDL/pull/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).
---
 cbits/sdlhelper.c    | 11 +++++++++++
 include/sdlhelper.h  |  2 ++
 src/SDL/Event.hs     | 20 +++++++++++++++-----
 src/SDL/Raw/Event.hs |  7 ++++++-
 4 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/cbits/sdlhelper.c b/cbits/sdlhelper.c
index 97ac752a..b64a52e9 100644
--- a/cbits/sdlhelper.c
+++ b/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);
diff --git a/include/sdlhelper.h b/include/sdlhelper.h
index 51784c98..ad226aa5 100644
--- a/include/sdlhelper.h
+++ b/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);
diff --git a/src/SDL/Event.hs b/src/SDL/Event.hs
index 95dd2a64..5d88089f 100644
--- a/src/SDL/Event.hs
+++ b/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
+        then (peeped ++) <$> peepAllEvents
+        else return peeped
 
 -- | Run a monadic computation, accumulating over all known 'Event's.
 --
diff --git a/src/SDL/Raw/Event.hs b/src/SDL/Raw/Event.hs
index 5903d4ab..5de95fa5 100644
--- a/src/SDL/Raw/Event.hs
+++ b/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 #-}