git.iko.soy/reflex-dom
on develop help sign in
Merge pull request #342 from meditans/cn-return-correct-result-for-wheel

Return correct result for Wheel

commit55a24020fb862b27e06c4d6a52c5087195bc3572 authorElliot Cameron <3noch@users.noreply.github.com> dateTue 17 Mar 2020, 12:14 (7 years ago) parent808d87508b6330
3 files changed+37−3
compare with develop
unifiedsplit
reflex-dom-core/ChangeLog.md+3 reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+11−1 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+23−2
reflex-dom-core/ChangeLog.md+3
@@ -40,6 +40,9 @@
4040
4141 * Add `< 0.7` upper bound for reflex
4242
43+* *(Breaking change)* The mouse wheel event now is a `WheelEventResult` rather than `()`.
44+ This provides information about the wheel's motion beyond the fact that it merely moved.
45+
4346## 0.5.2
4447
4548* Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).
reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+11−1
@@ -159,7 +159,17 @@ type family EventResultType (en :: EventTag) :: * where
159159 EventResultType 'TouchmoveTag = TouchEventResult
160160 EventResultType 'TouchendTag = TouchEventResult
161161 EventResultType 'TouchcancelTag = TouchEventResult
162− EventResultType 'WheelTag = ()
162+ EventResultType 'WheelTag = WheelEventResult
163+
164+data DeltaMode = DeltaPixel | DeltaLine | DeltaPage
165+ deriving (Show, Read, Eq, Ord, Bounded, Enum)
166+
167+data WheelEventResult = WheelEventResult
168+ { _wheelEventResult_deltaX :: Double
169+ , _wheelEventResult_deltaY :: Double
170+ , _wheelEventResult_deltaZ :: Double
171+ , _wheelEventResult_deltaMode :: DeltaMode
172+ } deriving (Show, Read, Eq, Ord)
163173
164174data TouchEventResult = TouchEventResult
165175 { _touchEventResult_altKey :: Bool
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+23−2
@@ -192,6 +192,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
192192import qualified GHCJS.DOM.TouchList as TouchList
193193import qualified GHCJS.DOM.Types as DOM
194194import qualified GHCJS.DOM.Window as Window
195+import qualified GHCJS.DOM.WheelEvent as WheelEvent
195196import qualified Reflex.Patch.DMap as PatchDMap
196197import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197198import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -2249,7 +2250,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22492250 Touchend -> getTouchEvent
22502251 Touchcancel -> getTouchEvent
22512252 Mousewheel -> return ()
2252− Wheel -> return ()
2253+ Wheel -> getWheelEvent
22532254
22542255{-# INLINABLE defaultDomWindowEventHandler #-}
22552256defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2299,7 +2300,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22992300 Touchend -> getTouchEvent
23002301 Touchcancel -> getTouchEvent
23012302 Mousewheel -> return ()
2302− Wheel -> return ()
2303+ Wheel -> getWheelEvent
23032304
23042305{-# INLINABLE withIsEvent #-}
23052306withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2608,6 +2609,26 @@ getTouchEvent = do
26082609 , _touchEventResult_touches = touches
26092610 }
26102611
2612+{-# INLINABLE getWheelEvent #-}
2613+getWheelEvent :: EventM e WheelEvent WheelEventResult
2614+getWheelEvent = do
2615+ e <- event
2616+ dx :: Double <- WheelEvent.getDeltaX e
2617+ dy :: Double <- WheelEvent.getDeltaY e
2618+ dz :: Double <- WheelEvent.getDeltaZ e
2619+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2620+ return $ WheelEventResult
2621+ { _wheelEventResult_deltaX = dx
2622+ , _wheelEventResult_deltaY = dy
2623+ , _wheelEventResult_deltaZ = dz
2624+ , _wheelEventResult_deltaMode = case deltaMode of
2625+ 0 -> DeltaPixel
2626+ 1 -> DeltaLine
2627+ 2 -> DeltaPage
2628+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
2629+ _ -> error "getWheelEvent: impossible encoding"
2630+ }
2631+
26112632instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26122633 {-# INLINABLE sample #-}
26132634 sample = lift . sample