git.iko.soy/reflex-dom
on develop help sign in
Return correct result for Wheel
commit48372d57fcce9a446e33994ae3d13a38568f17f1 authorCarlo Nucera <carlo.nucera@protonmail.com> dateSat 16 Nov 2019, 12:49 (7 years ago) parent8214a67
2 files changed+33−3
compare with develop
unifiedsplit
reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+11−1 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+22−2
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)
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+22−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
@@ -2241,7 +2242,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22412242 Touchend -> getTouchEvent
22422243 Touchcancel -> getTouchEvent
22432244 Mousewheel -> return ()
2244− Wheel -> return ()
2245+ Wheel -> getWheelEvent
22452246
22462247{-# INLINABLE defaultDomWindowEventHandler #-}
22472248defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2291,7 +2292,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22912292 Touchend -> getTouchEvent
22922293 Touchcancel -> getTouchEvent
22932294 Mousewheel -> return ()
2294− Wheel -> return ()
2295+ Wheel -> getWheelEvent
22952296
22962297{-# INLINABLE withIsEvent #-}
22972298withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2600,6 +2601,25 @@ getTouchEvent = do
26002601 , _touchEventResult_touches = touches
26012602 }
26022603
2604+{-# INLINABLE getWheelEvent #-}
2605+getWheelEvent :: EventM e WheelEvent WheelEventResult
2606+getWheelEvent = do
2607+ e <- event
2608+ dx :: Double <- WheelEvent.getDeltaX e
2609+ dy :: Double <- WheelEvent.getDeltaY e
2610+ dz :: Double <- WheelEvent.getDeltaZ e
2611+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2612+ return $ WheelEventResult
2613+ { _wheelEventResult_deltaX = dx
2614+ , _wheelEventResult_deltaY = dy
2615+ , _wheelEventResult_deltaZ = dz
2616+ , _wheelEventResult_deltaMode = case deltaMode of
2617+ 0 -> DeltaPixel
2618+ 1 -> DeltaLine
2619+ 2 -> DeltaPage
2620+ _ -> error "getWheelEvent: impossible encoding"
2621+ }
2622+
26032623instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26042624 {-# INLINABLE sample #-}
26052625 sample = lift . sample