Add mouse wheel event

helm.cabal

@@ -53,7 +53,7 @@ library
     pango >= 0.13 && < 0.14,
     containers >= 0.5 && < 1,
     elerea >= 2.9 && < 3,
-    sdl2 > 2.1.1 && < 3,
+    sdl2 > 2.2 && < 3,
     linear >= 1 && < 2,
     text >= 1.1.1.3 && < 2,
     mtl >= 2.1 && < 3,

src/Helm/Engine.hs

@@ -59,6 +59,9 @@ class Engine e where
   -- | The mouse click signal, with events provided by the engine.
   mouseClickSignal :: e -> SignalGen e (Signal [(MouseButton, V2 Int)])
 
+  -- | The mouse wheel signal, with events provided by the engine.
+  mouseWheelSignal :: e -> SignalGen e (Signal [V2 Int])
+
   -- | The keyboard down signal, with events provided by the engine.
   keyboardDownSignal :: e -> SignalGen e (Signal [Key])
 

src/Helm/Engine/SDL/Engine.hs

@@ -32,6 +32,7 @@ import qualified SDL
 import qualified SDL.Event as Event
 import qualified SDL.Init as Init
 import           SDL.Input.Keyboard (Keysym(..))
+import           SDL.Input.Mouse (MouseScrollDirection(..))
 import qualified SDL.Time as Time
 import qualified SDL.Video as Video
 import           SDL.Video (WindowConfig(..))
@@ -72,7 +73,9 @@ data SDLEngine = SDLEngine
   , mouseUpEventSink :: (MouseButton, V2 Int) -> IO ()                             -- ^ The mouse up event sink.
   , mouseClickEventSignal :: SignalGen SDLEngine (Signal [(MouseButton, V2 Int)])  -- ^ The mouse click event signal.
   , mouseClickEventSink :: (MouseButton, V2 Int) -> IO ()                          -- ^ The mouse click event sink.
-
+  , mouseWheelEventSignal ::
+      SignalGen SDLEngine (Signal [V2 Int])                                        -- ^ The mouse wheel event signal.
+  , mouseWheelEventSink :: V2 Int -> IO ()                                         -- ^ The mouse wheel event sink.
   , keyboardDownEventSignal :: SignalGen SDLEngine (Signal [Key])                  -- ^ The keyboard down event signal.
   , keyboardDownEventSink :: Key -> IO ()                                          -- ^ The keyboard down event sink.
   , keyboardUpEventSignal :: SignalGen SDLEngine (Signal [Key])                    -- ^ The keyboard up event signal.
@@ -153,6 +156,8 @@ instance Engine SDLEngine where
   -- | The SDL-specific mouse click signal.
   mouseClickSignal = mouseClickEventSignal
 
+  mouseWheelSignal = mouseWheelEventSignal
+
   -- | The SDL-specific keyboard down signal.
   keyboardDownSignal = keyboardDownEventSignal
 
@@ -214,6 +219,7 @@ startupWith config@SDLEngineConfig { .. } = do
   mouseDownEvent <- externalMulti
   mouseUpEvent <- externalMulti
   mouseClickEvent <- externalMulti
+  mouseWheelEvent <- externalMulti
   keyboardDownEvent <- externalMulti
   keyboardUpEvent <- externalMulti
   keyboardPressEvent <- externalMulti
@@ -237,6 +243,8 @@ startupWith config@SDLEngineConfig { .. } = do
     , mouseUpEventSink = snd mouseUpEvent
     , mouseClickEventSignal = fst mouseClickEvent
     , mouseClickEventSink = snd mouseClickEvent
+    , mouseWheelEventSignal = fst mouseWheelEvent
+    , mouseWheelEventSink = snd mouseWheelEvent
 
     , keyboardDownEventSignal = fst keyboardDownEvent
     , keyboardDownEventSink = snd keyboardDownEvent
@@ -519,6 +527,17 @@ sinkEvent engine (Event.MouseMotionEvent Event.MouseMotionEventData { .. }) = do
 
   return engine
 
+-- Sink mouse wheel events as mouse wheels.
+sinkEvent engine (Event.MouseWheelEvent Event.MouseWheelEventData {..}) = do
+  mouseWheelEventSink engine pos'
+
+  return engine
+  where
+    pos = fromIntegral <$> mouseWheelEventPos
+    pos' = case mouseWheelEventDirection of
+      ScrollNormal -> pos
+      ScrollFlipped -> pos * V2 (-1) (-1)
+
 -- Sink keyboard events into the relevant Elerea sinks.
 --
 -- Note that keyboard up and press are the same for the time being.

src/Helm/Mouse.hs

@@ -8,6 +8,7 @@ module Helm.Mouse
   , clicks
   , downs
   , ups
+  , wheels
   ) where
 
 import FRP.Elerea.Param (input, snapshot)
@@ -60,3 +61,13 @@ ups f = Sub $ do
   engine <- input >>= snapshot
 
   fmap (fmap (uncurry f)) <$> mouseUpSignal engine
+
+-- | Subscribe to mouse wheel events and map to a game action
+wheels
+  :: Engine e
+  => (V2 Int -> a)  -- ^ The function to map a mouse wheel and wheel direction to an action.
+  -> Sub e a        -- ^ The mapped subscription
+wheels f = Sub $ do
+  engine <- input >>= snapshot
+
+  fmap (fmap f) <$> mouseWheelSignal engine

stack.yaml

@@ -4,5 +4,5 @@ packages:
 extra-deps:
   - elerea-2.9.0
   - text-1.2.2.0
-  - sdl2-2.1.3
+  - sdl2-2.2.0
 resolver: lts-8.18