48372d5 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Return correct result for Wheel

48372d5Carlo Nucera7 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+11−1

compare with develop

unifiedsplit

@@ -159,7 +159,17 @@ type family EventResultType (en :: EventTag) :: * where

159 EventResultType 'TouchmoveTag = TouchEventResult

160 EventResultType 'TouchendTag = 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)

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+22−2

@@ -192,6 +192,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent

192import qualified GHCJS.DOM.TouchList as TouchList

193import qualified GHCJS.DOM.Types as DOM

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

@@ -2241,7 +2242,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of

2241 Touchend -> getTouchEvent

2242 Touchend -> getTouchEvent

2242 Touchcancel -> getTouchEvent

2243 Touchcancel -> getTouchEvent

2243 Mousewheel -> return ()

2244 Mousewheel -> return ()

2244− Wheel -> return ()

2245+ Wheel -> getWheelEvent

2245

2246

2246{-# INLINABLE defaultDomWindowEventHandler #-}

2247{-# INLINABLE defaultDomWindowEventHandler #-}

2247defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))

2248defaultDomWindowEventHandler :: 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

2291 Touchend -> getTouchEvent

2292 Touchend -> getTouchEvent

2292 Touchcancel -> getTouchEvent

2293 Touchcancel -> getTouchEvent

2293 Mousewheel -> return ()

2294 Mousewheel -> return ()

2294− Wheel -> return ()

2295+ Wheel -> getWheelEvent

2295

2296

2296{-# INLINABLE withIsEvent #-}

2297{-# INLINABLE withIsEvent #-}

2297withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r

2298withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r

@@ -2600,6 +2601,25 @@ getTouchEvent = do

2600 , _touchEventResult_touches = touches

2601 , _touchEventResult_touches = touches

2601 }

2602 }

2602

2603

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+

2603instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where

2623instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where

2604 {-# INLINABLE sample #-}

2624 {-# INLINABLE sample #-}

2605 sample = lift . sample

2625 sample = lift . sample