@@ -107,6 +107,9 @@ module Reflex.Dom.Builder.Immediate
107107 , WindowConfig (..)
108108 , Window (..)
109109 , wrapWindow
110+ -- * Attributes for controlling hydration
111+ , hydratableAttribute
112+ , skipHydrationAttribute
110113 -- * Internal
111114 , traverseDMapWithKeyWithAdjust'
112115 , hoistTraverseWithKeyWithAdjust
@@ -137,11 +140,12 @@ import Data.IntMap.Strict (IntMap)
137140import Data.Maybe
138141import Data.Monoid ((<>))
139142import Data.Some (Some(..))
143+import Data.String (IsString)
140144import Data.Text (Text)
141145import Foreign.JavaScript.Internal.Utils
142146import Foreign.JavaScript.TH
143147import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
144−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
148+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
145149import GHCJS.DOM.EventM (EventM, event, on)
146150import GHCJS.DOM.KeyboardEvent as KeyboardEvent
147151import GHCJS.DOM.MouseEvent
@@ -192,6 +196,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
192196import qualified GHCJS.DOM.TouchList as TouchList
193197import qualified GHCJS.DOM.Types as DOM
194198import qualified GHCJS.DOM.Window as Window
199+import qualified GHCJS.DOM.WheelEvent as WheelEvent
195200import qualified Reflex.Patch.DMap as PatchDMap
196201import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197202import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -318,8 +323,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
318323addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319324 HydrationMode_Immediate -> pure ()
320325 HydrationMode_Hydrating -> do
321− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
326+ s <- lift setup
323327 addHydrationStep (f s)
324328
325329-- | Add a hydration step
@@ -743,6 +747,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
743747 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
744748 #-}
745749
750+-- | An attribute which causes hydration to skip over an element completely.
751+skipHydrationAttribute :: IsString s => s
752+skipHydrationAttribute = "data-hydration-skip"
753+
754+-- | An attribute which signals that an element should be hydrated.
755+hydratableAttribute :: IsString s => s
756+hydratableAttribute = "data-ssr"
757+
746758{-# INLINE hydrateElement #-}
747759hydrateElement
748760 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
@@ -764,18 +776,15 @@ hydrateElement elementTag cfg child = do
764776 }
765777 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
766778 wrapResult <- liftIO newEmptyMVar
767− let skipAttr = "data-hydration-skip" :: DOM.JSString
768− ssrAttr = "data-ssr" :: DOM.JSString
779+ let -- Determine if we should skip an element. We currently skip elements for
780+ -- two reasons:
781+ -- 1) it was not produced by a static builder which supports hydration
782+ -- 2) it is explicitly marked to be skipped
769783 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
784+ shouldSkip e = do
785+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
786+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
787+ pure $ skip || not hydratable
779788 childDom <- liftIO $ readIORef childDelayedRef
780789 let rawCfg = extractRawElementConfig cfg
781790 doc <- askDocument
@@ -791,7 +800,7 @@ hydrateElement elementTag cfg child = do
791800 Just node -> DOM.castTo DOM.Element node >>= \case
792801 Nothing -> go (Just node) -- this node is not an element, skip
793802 Just e -> shouldSkip e >>= \case
794− True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
803+ True -> go (Just node) -- this element should be skipped by hydration
795804 False -> do
796805 t <- Element.getTagName e
797806 -- TODO: check attributes?
@@ -1277,8 +1286,8 @@ hydrateComment doc t mSetContents = do
12771286skipToAndReplaceComment
12781287 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
12791288 => Text
1280− -> IORef Text
1281− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1289+ -> IORef (Maybe Text)
1290+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
12821291skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12831292 HydrationMode_Immediate -> do
12841293 -- If we're in immediate mode, we don't try to replace an existing comment,
@@ -1286,43 +1295,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12861295 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
12871296 append $ toNode t
12881297 textNodeRef <- liftIO $ newIORef t
1289− keyRef <- liftIO $ newIORef ""
1298+ keyRef <- liftIO $ newIORef Nothing
12901299 pure (pure (), textNodeRef, keyRef)
12911300 HydrationMode_Hydrating -> do
12921301 doc <- askDocument
12931302 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
12941303 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
1304+ let
1305+ go Nothing _ = do
1306+ tn <- createTextNode doc ("" :: Text)
1307+ insertAfterPreviousNode tn
1308+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1309+ pure (tn, Nothing)
1310+ go (Just key0) mLastNode = do
1311+ parent <- askParent
1312+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1313+ Nothing -> go Nothing Nothing
1314+ Just node -> DOM.castTo DOM.Comment node >>= \case
12991315 Just comment -> do
1300− commentText <- Node.getTextContentUnchecked comment
1301− case T.stripPrefix (prefix <> key0) commentText of
1316+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
1317+ 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.
13021318 Just key -> do
13031319 -- Replace the comment with an (invisible) text node
13041320 tn <- createTextNode doc ("" :: Text)
13051321 Node.replaceChild_ parent tn comment
1306− pure (tn, key)
1322+ pure (tn, Just key)
13071323 Nothing -> do
1308− go key0 (Just node)
1324+ go (Just key0) (Just node)
13091325 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
1326+ go (Just key0) (Just node)
1327+ switchComment = do
1328+ key0 <- liftIO $ readIORef key0Ref
1329+ (tn, key) <- go key0 =<< getPreviousNode
1330+ setPreviousNode $ Just $ toNode tn
1331+ liftIO $ do
1332+ writeIORef textNodeRef tn
1333+ writeIORef keyRef key
13181334 pure (switchComment, textNodeRef, keyRef)
13191335
13201336{-# 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 "")
1337+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))
1338+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
13231339
13241340{-# 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)
1341+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)
13261342skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
13271343
13281344instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
@@ -2248,7 +2264,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22482264 Touchend -> getTouchEvent
22492265 Touchcancel -> getTouchEvent
22502266 Mousewheel -> return ()
2251− Wheel -> return ()
2267+ Wheel -> getWheelEvent
22522268
22532269{-# INLINABLE defaultDomWindowEventHandler #-}
22542270defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2298,7 +2314,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22982314 Touchend -> getTouchEvent
22992315 Touchcancel -> getTouchEvent
23002316 Mousewheel -> return ()
2301− Wheel -> return ()
2317+ Wheel -> getWheelEvent
23022318
23032319{-# INLINABLE withIsEvent #-}
23042320withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2607,6 +2623,26 @@ getTouchEvent = do
26072623 , _touchEventResult_touches = touches
26082624 }
26092625
2626+{-# INLINABLE getWheelEvent #-}
2627+getWheelEvent :: EventM e WheelEvent WheelEventResult
2628+getWheelEvent = do
2629+ e <- event
2630+ dx :: Double <- WheelEvent.getDeltaX e
2631+ dy :: Double <- WheelEvent.getDeltaY e
2632+ dz :: Double <- WheelEvent.getDeltaZ e
2633+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2634+ return $ WheelEventResult
2635+ { _wheelEventResult_deltaX = dx
2636+ , _wheelEventResult_deltaY = dy
2637+ , _wheelEventResult_deltaZ = dz
2638+ , _wheelEventResult_deltaMode = case deltaMode of
2639+ 0 -> DeltaPixel
2640+ 1 -> DeltaLine
2641+ 2 -> DeltaPage
2642+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
2643+ _ -> error "getWheelEvent: impossible encoding"
2644+ }
2645+
26102646instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26112647 {-# INLINABLE sample #-}
26122648 sample = lift . sample