@@ -141,7 +141,7 @@ import Data.Text (Text)
141141import Foreign.JavaScript.Internal.Utils
142142import Foreign.JavaScript.TH
143143import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
144−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
144+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
145145import GHCJS.DOM.EventM (EventM, event, on)
146146import GHCJS.DOM.KeyboardEvent as KeyboardEvent
147147import GHCJS.DOM.MouseEvent
@@ -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
@@ -318,8 +319,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
318319addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319320 HydrationMode_Immediate -> pure ()
320321 HydrationMode_Hydrating -> do
321− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
322+ s <- lift setup
323323 addHydrationStep (f s)
324324
325325-- | Add a hydration step
@@ -767,15 +767,10 @@ hydrateElement elementTag cfg child = do
767767 let skipAttr = "data-hydration-skip" :: DOM.JSString
768768 ssrAttr = "data-ssr" :: DOM.JSString
769769 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
770− shouldSkip e = case cfg ^. namespace of
771− Nothing -> do
772− skip <- hasAttribute e skipAttr
773− ssr <- hasAttribute e ssrAttr
774− pure $ skip || not ssr
775− Just ns -> do
776− skip <- hasAttributeNS e (Just ns) skipAttr
777− ssr <- hasAttributeNS e (Just ns) ssrAttr
778− pure $ skip || not ssr
770+ shouldSkip e = do
771+ skip <- hasAttribute e skipAttr
772+ ssr <- hasAttribute e ssrAttr
773+ pure $ skip || not ssr
779774 childDom <- liftIO $ readIORef childDelayedRef
780775 let rawCfg = extractRawElementConfig cfg
781776 doc <- askDocument
@@ -1277,8 +1272,8 @@ hydrateComment doc t mSetContents = do
12771272skipToAndReplaceComment
12781273 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
12791274 => Text
1280− -> IORef Text
1281− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1275+ -> IORef (Maybe Text)
1276+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
12821277skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12831278 HydrationMode_Immediate -> do
12841279 -- If we're in immediate mode, we don't try to replace an existing comment,
@@ -1286,43 +1281,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12861281 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
12871282 append $ toNode t
12881283 textNodeRef <- liftIO $ newIORef t
1289− keyRef <- liftIO $ newIORef ""
1284+ keyRef <- liftIO $ newIORef Nothing
12901285 pure (pure (), textNodeRef, keyRef)
12911286 HydrationMode_Hydrating -> do
12921287 doc <- askDocument
12931288 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
12941289 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1295− let go key0 mLastNode = do
1296− parent <- askParent
1297− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1298− DOM.castTo DOM.Comment node >>= \case
1290+ let
1291+ go Nothing _ = do
1292+ tn <- createTextNode doc ("" :: Text)
1293+ insertAfterPreviousNode tn
1294+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1295+ pure (tn, Nothing)
1296+ go (Just key0) mLastNode = do
1297+ parent <- askParent
1298+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1299+ Nothing -> go Nothing Nothing
1300+ Just node -> DOM.castTo DOM.Comment node >>= \case
12991301 Just comment -> do
1300− commentText <- Node.getTextContentUnchecked comment
1301− case T.stripPrefix (prefix <> key0) commentText of
1302+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
1303+ case T.stripPrefix (prefix <> key0) commentText of -- 'key0' may be @""@ in which case we're just finding the actual key; TODO: Don't be clever.
13021304 Just key -> do
13031305 -- Replace the comment with an (invisible) text node
13041306 tn <- createTextNode doc ("" :: Text)
13051307 Node.replaceChild_ parent tn comment
1306− pure (tn, key)
1308+ pure (tn, Just key)
13071309 Nothing -> do
1308− go key0 (Just node)
1310+ go (Just key0) (Just node)
13091311 Nothing -> do
1310− go key0 (Just node)
1311− switchComment = do
1312− key0 <- liftIO $ readIORef key0Ref
1313− (tn, key) <- go key0 =<< getPreviousNode
1314− setPreviousNode $ Just $ toNode tn
1315− liftIO $ do
1316− writeIORef textNodeRef tn
1317− writeIORef keyRef key
1312+ go (Just key0) (Just node)
1313+ switchComment = do
1314+ key0 <- liftIO $ readIORef key0Ref
1315+ (tn, key) <- go key0 =<< getPreviousNode
1316+ setPreviousNode $ Just $ toNode tn
1317+ liftIO $ do
1318+ writeIORef textNodeRef tn
1319+ writeIORef keyRef key
13181320 pure (switchComment, textNodeRef, keyRef)
13191321
13201322{-# INLINABLE skipToReplaceStart #-}
1321−skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1322−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1323+skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
1324+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
13231325
13241326{-# INLINABLE skipToReplaceEnd #-}
1325−skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
1327+skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef (Maybe Text) -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
13261328skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
13271329
13281330instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
@@ -2248,7 +2250,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22482250 Touchend -> getTouchEvent
22492251 Touchcancel -> getTouchEvent
22502252 Mousewheel -> return ()
2251− Wheel -> return ()
2253+ Wheel -> getWheelEvent
22522254
22532255{-# INLINABLE defaultDomWindowEventHandler #-}
22542256defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2298,7 +2300,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22982300 Touchend -> getTouchEvent
22992301 Touchcancel -> getTouchEvent
23002302 Mousewheel -> return ()
2301− Wheel -> return ()
2303+ Wheel -> getWheelEvent
23022304
23032305{-# INLINABLE withIsEvent #-}
23042306withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2607,6 +2609,26 @@ getTouchEvent = do
26072609 , _touchEventResult_touches = touches
26082610 }
26092611
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+
26102632instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26112633 {-# INLINABLE sample #-}
26122634 sample = lift . sample