git.iko.soy/reflex-dom
on develop help sign in
Merge pull request #342 from meditans/cn-return-correct-result-for-wheel
55a2402Elliot Cameron
reflex-dom-core/ChangeLog.md+3
compare with develop
unifiedsplit
@@ -40,6 +40,9 @@
40
40
41 * Add `< 0.7` upper bound for reflex
41 * Add `< 0.7` upper bound for reflex
42
42
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+
43## 0.5.2
46## 0.5.2
44
47
45* Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).
48* 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
159 EventResultType 'TouchmoveTag = TouchEventResult
159 EventResultType 'TouchmoveTag = TouchEventResult
160 EventResultType 'TouchendTag = TouchEventResult
160 EventResultType 'TouchendTag = TouchEventResult
161 EventResultType 'TouchcancelTag = TouchEventResult
161 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)
163
173
164data TouchEventResult = TouchEventResult
174data TouchEventResult = TouchEventResult
165 { _touchEventResult_altKey :: Bool
175 { _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
192import qualified GHCJS.DOM.TouchList as TouchList
192import qualified GHCJS.DOM.TouchList as TouchList
193import qualified GHCJS.DOM.Types as DOM
193import qualified GHCJS.DOM.Types as DOM
194import qualified GHCJS.DOM.Window as Window
194import qualified GHCJS.DOM.Window as Window
195+import qualified GHCJS.DOM.WheelEvent as WheelEvent
195import qualified Reflex.Patch.DMap as PatchDMap
196import qualified Reflex.Patch.DMap as PatchDMap
196import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
198import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -2249,7 +2250,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
2249 Touchend -> getTouchEvent
2250 Touchend -> getTouchEvent
2250 Touchcancel -> getTouchEvent
2251 Touchcancel -> getTouchEvent
2251 Mousewheel -> return ()
2252 Mousewheel -> return ()
2252− Wheel -> return ()
2253+ Wheel -> getWheelEvent
2253
2254
2254{-# INLINABLE defaultDomWindowEventHandler #-}
2255{-# INLINABLE defaultDomWindowEventHandler #-}
2255defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
2256defaultDomWindowEventHandler :: 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
2299 Touchend -> getTouchEvent
2300 Touchend -> getTouchEvent
2300 Touchcancel -> getTouchEvent
2301 Touchcancel -> getTouchEvent
2301 Mousewheel -> return ()
2302 Mousewheel -> return ()
2302− Wheel -> return ()
2303+ Wheel -> getWheelEvent
2303
2304
2304{-# INLINABLE withIsEvent #-}
2305{-# INLINABLE withIsEvent #-}
2305withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
2306withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2608,6 +2609,26 @@ getTouchEvent = do
2608 , _touchEventResult_touches = touches
2609 , _touchEventResult_touches = touches
2609 }
2610 }
2610
2611
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+
2611instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
2632instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
2612 {-# INLINABLE sample #-}
2633 {-# INLINABLE sample #-}
2613 sample = lift . sample
2634 sample = lift . sample