mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
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
This commit is contained in:
parent
332529a67a
commit
6fab35c929
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: monomer
|
||||
version: 1.1.0.0
|
||||
version: 1.1.0.1
|
||||
github: fjvallarino/monomer
|
||||
license: BSD3
|
||||
author: Francisco Vallarino
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user