Fix mouse wheel/trackpad handling (#27)

* Do not force scroll direction based on Wheel direction argument (axis movement arguments already have that information applied)

* Bump version

* Handle wheel movement at event conversion level. Apply adjustments based on platform

* Restore old naming convention

* Update changelog

ChangeLog.md

@@ -1,3 +1,8 @@
+### 1.1.0.1
+
+- Fix horizontal wheel/trackpad scrolling on Linux.
+- Scroll: do not use direction argument to modify wheel/trackpad direction (event provides correct value).
+
 ### 1.1.0.0
 
 - Reduce memory usage by sharing wreq session among image widget instances.

monomer.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           monomer
-version:        1.1.0.0
+version:        1.1.0.1
 synopsis:       A GUI library for writing native Haskell applications.
 description:    Monomer is an easy to use, cross platform, GUI library for writing native
                 Haskell applications.

package.yaml

@@ -1,5 +1,5 @@
 name: monomer
-version: 1.1.0.0
+version: 1.1.0.1
 github: fjvallarino/monomer
 license: BSD3
 author: Francisco Vallarino

src/Monomer/Event/Core.hs

@@ -9,6 +9,7 @@ Portability : non-portable
 Core functions for SDL event processing and conversion.
 -}
 module Monomer.Event.Core (
+  ConvertEventsCfg(..),
   isActionEvent,
   convertEvents,
   translateEvent
@@ -16,6 +17,7 @@ module Monomer.Event.Core (
 
 import Control.Applicative ((<|>))
 import Data.Maybe (catMaybes, fromMaybe)
+import Data.Text (Text)
 
 import qualified Data.Map.Strict as M
 import qualified SDL
@@ -37,19 +39,27 @@ isActionEvent SDL.KeyboardEvent{} = True
 isActionEvent SDL.TextInputEvent{} = True
 isActionEvent _ = False
 
+data ConvertEventsCfg = ConvertEventsCfg {
+  _cecOs :: Text,           -- ^ The host operating system.
+  _cecDpr :: Double,        -- ^ Device pixel rate.
+  _cecEpr :: Double,        -- ^ Event pixel rate.
+  _cecInvertWheelX :: Bool, -- ^ Whether wheel/trackpad x direction should be inverted.
+  _cecInvertWheelY :: Bool  -- ^ Whether wheel/trackpad y direction should be inverted.
+} deriving (Eq, Show)
+
 -- | Converts SDL events to Monomer's SystemEvent
 convertEvents
-  :: Double              -- ^ Device pixel rate.
-  -> Double              -- ^ Event pixel rate.
+  :: ConvertEventsCfg    -- ^ Settings for event conversion.
   -> Point               -- ^ Mouse position.
   -> [SDL.EventPayload]  -- ^ List of SDL events.
   -> [SystemEvent]       -- ^ List of Monomer events.
-convertEvents dpr epr mousePos events = catMaybes convertedEvents where
+convertEvents cfg mousePos events = catMaybes convertedEvents where
+  ConvertEventsCfg os dpr epr invertX invertY = cfg
   convertedEvents = fmap convertEvent events
   convertEvent evt =
     mouseMoveEvent mousePos evt
     <|> mouseClick mousePos evt
-    <|> mouseWheelEvent epr mousePos evt
+    <|> mouseWheelEvent cfg mousePos evt
     <|> mouseMoveLeave mousePos evt
     <|> keyboardEvent evt
     <|> textEvent evt
@@ -94,18 +104,25 @@ mouseMoveLeave mousePos SDL.WindowLostMouseFocusEvent{} = evt where
   evt = Just $ Move (Point (-1) (-1))
 mouseMoveLeave mousePos _ = Nothing
 
-mouseWheelEvent :: Double -> Point -> SDL.EventPayload -> Maybe SystemEvent
-mouseWheelEvent epr mousePos (SDL.MouseWheelEvent eventData) = systemEvent where
+mouseWheelEvent :: ConvertEventsCfg -> Point -> SDL.EventPayload -> Maybe SystemEvent
+mouseWheelEvent cfg pos (SDL.MouseWheelEvent eventData) = systemEvent where
+  ConvertEventsCfg os dpr epr invertX invertY = cfg
+  signX = if invertX then -1 else 1
+  signY = if invertY then -1 else 1
+  factorX
+    | os == "Windows" || os == "Mac OS X" = -signX
+    | otherwise = signX
+  factorY = signY
   wheelDirection = case SDL.mouseWheelEventDirection eventData of
     SDL.ScrollNormal -> WheelNormal
     SDL.ScrollFlipped -> WheelFlipped
   SDL.V2 x y = SDL.mouseWheelEventPos eventData
-  wheelDelta = Point (fromIntegral x * epr) (fromIntegral y * epr)
+  wheelDelta = Point (factorX * fromIntegral x * epr) (factorY * fromIntegral y * epr)
 
   systemEvent = case SDL.mouseWheelEventWhich eventData of
-    SDL.Mouse _ -> Just $ WheelScroll mousePos wheelDelta wheelDirection
+    SDL.Mouse _ -> Just $ WheelScroll pos wheelDelta wheelDirection
     SDL.Touch -> Nothing
-mouseWheelEvent epr mousePos _ = Nothing
+mouseWheelEvent cfg mousePos _ = Nothing
 
 keyboardEvent :: SDL.EventPayload -> Maybe SystemEvent
 keyboardEvent (SDL.KeyboardEvent eventData) = Just keyAction where

src/Monomer/Main/Core.hs

@@ -244,7 +244,10 @@ mainLoop window fontManager config loopArgs = do
   let windowResized = currWinSize /= windowSize && isWindowResized eventsPayload
   let windowExposed = isWindowExposed eventsPayload
   let mouseEntered = isMouseEntered eventsPayload
-  let baseSystemEvents = convertEvents dpr epr mousePos eventsPayload
+  let invertX = fromMaybe False (_apcInvertWheelX config)
+  let invertY = fromMaybe False (_apcInvertWheelY config)
+  let convertCfg = ConvertEventsCfg _mlOS dpr epr invertX invertY
+  let baseSystemEvents = convertEvents convertCfg mousePos eventsPayload
 
 --  when newSecond $
 --    liftIO . putStrLn $ "Frames: " ++ show _mlFrameCount

src/Monomer/Main/Types.hs

@@ -185,7 +185,11 @@ data AppConfig e = AppConfig {
   -- | Defines which mouse button is considered main.
   _apcMainButton :: Maybe Button,
   -- | Defines which mouse button is considered secondary or context button.
-  _apcContextButton :: Maybe Button
+  _apcContextButton :: Maybe Button,
+  -- | Whether wheel/trackpad horizontal movement should be inverted.
+  _apcInvertWheelX :: Maybe Bool,
+  -- | Whether wheel/trackpad vertical movement should be inverted.
+  _apcInvertWheelY :: Maybe Bool
 }
 
 instance Default (AppConfig e) where
@@ -204,7 +208,9 @@ instance Default (AppConfig e) where
     _apcExitEvent = [],
     _apcResizeEvent = [],
     _apcMainButton = Nothing,
-    _apcContextButton = Nothing
+    _apcContextButton = Nothing,
+    _apcInvertWheelX = Nothing,
+    _apcInvertWheelY = Nothing
   }
 
 instance Semigroup (AppConfig e) where
@@ -223,7 +229,9 @@ instance Semigroup (AppConfig e) where
     _apcExitEvent = _apcExitEvent a1 ++ _apcExitEvent a2,
     _apcResizeEvent = _apcResizeEvent a1 ++ _apcResizeEvent a2,
     _apcMainButton = _apcMainButton a2 <|> _apcMainButton a1,
-    _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1
+    _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1,
+    _apcInvertWheelX = _apcInvertWheelX a2 <|> _apcInvertWheelX a1,
+    _apcInvertWheelY = _apcInvertWheelY a2 <|> _apcInvertWheelY a1
   }
 
 instance Monoid (AppConfig e) where
@@ -338,3 +346,21 @@ appContextButton :: Button -> AppConfig e
 appContextButton btn = def {
   _apcContextButton = Just btn
 }
+
+{-|
+Whether the horizontal wheel/trackpad movement should be inverted. In general
+platform detection should do the right thing.
+-}
+appInvertWheelX :: Bool -> AppConfig e
+appInvertWheelX invert = def {
+  _apcInvertWheelX = Just invert
+}
+
+{-|
+Whether the vertical wheel/trackpad movement should be inverted. In general
+platform detection should do the right thing.
+-}
+appInvertWheelY :: Bool -> AppConfig e
+appInvertWheelY invert = def {
+  _apcInvertWheelY = Just invert
+}

src/Monomer/Widgets/Containers/Scroll.hs

@@ -510,12 +510,8 @@ makeScroll config state = widget where
       result
         | needsUpdate = Just $ makeResult newState
         | otherwise = Nothing
-      stepX
-        | wheelDirection == WheelNormal = -wheelRate * wx
-        | otherwise = wheelRate * wx
-      stepY
-        | wheelDirection == WheelNormal = wheelRate * wy
-        | otherwise = -wheelRate * wy
+      stepX = wheelRate * wx
+      stepY = wheelRate * wy
       newState = state {
         _sstDeltaX = scrollAxisH (stepX + dx),
         _sstDeltaY = scrollAxisV (stepY + dy)