@@ -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,12 +140,13 @@ 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.ClipboardEvent as ClipboardEvent
144148import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
145−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
149+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
146150import GHCJS.DOM.EventM (EventM, event, on)
147151import GHCJS.DOM.KeyboardEvent as KeyboardEvent
148152import GHCJS.DOM.MouseEvent
@@ -194,6 +198,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
194198import qualified GHCJS.DOM.TouchList as TouchList
195199import qualified GHCJS.DOM.Types as DOM
196200import qualified GHCJS.DOM.Window as Window
201+import qualified GHCJS.DOM.WheelEvent as WheelEvent
197202import qualified Reflex.Patch.DMap as PatchDMap
198203import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
199204import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -320,8 +325,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
320325addHydrationStepWithSetup setup f = getHydrationMode >>= \case
321326 HydrationMode_Immediate -> pure ()
322327 HydrationMode_Hydrating -> do
323− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
324− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
328+ s <- lift setup
325329 addHydrationStep (f s)
326330
327331-- | Add a hydration step
@@ -745,6 +749,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
745749 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
746750 #-}
747751
752+-- | An attribute which causes hydration to skip over an element completely.
753+skipHydrationAttribute :: IsString s => s
754+skipHydrationAttribute = "data-hydration-skip"
755+
756+-- | An attribute which signals that an element should be hydrated.
757+hydratableAttribute :: IsString s => s
758+hydratableAttribute = "data-ssr"
759+
748760{-# INLINE hydrateElement #-}
749761hydrateElement
750762 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
@@ -766,18 +778,15 @@ hydrateElement elementTag cfg child = do
766778 }
767779 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
768780 wrapResult <- liftIO newEmptyMVar
769− let skipAttr = "data-hydration-skip" :: DOM.JSString
770− ssrAttr = "data-ssr" :: DOM.JSString
781+ let -- Determine if we should skip an element. We currently skip elements for
782+ -- two reasons:
783+ -- 1) it was not produced by a static builder which supports hydration
784+ -- 2) it is explicitly marked to be skipped
771785 shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
772− shouldSkip e = case cfg ^. namespace of
773− Nothing -> do
774− skip <- hasAttribute e skipAttr
775− ssr <- hasAttribute e ssrAttr
776− pure $ skip || not ssr
777− Just ns -> do
778− skip <- hasAttributeNS e (Just ns) skipAttr
779− ssr <- hasAttributeNS e (Just ns) ssrAttr
780− pure $ skip || not ssr
786+ shouldSkip e = do
787+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
788+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
789+ pure $ skip || not hydratable
781790 childDom <- liftIO $ readIORef childDelayedRef
782791 let rawCfg = extractRawElementConfig cfg
783792 doc <- askDocument
@@ -793,7 +802,7 @@ hydrateElement elementTag cfg child = do
793802 Just node -> DOM.castTo DOM.Element node >>= \case
794803 Nothing -> go (Just node) -- this node is not an element, skip
795804 Just e -> shouldSkip e >>= \case
796− True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
805+ True -> go (Just node) -- this element should be skipped by hydration
797806 False -> do
798807 t <- Element.getTagName e
799808 -- TODO: check attributes?
@@ -1279,8 +1288,8 @@ hydrateComment doc t mSetContents = do
12791288skipToAndReplaceComment
12801289 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
12811290 => Text
1282− -> IORef Text
1283− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1291+ -> IORef (Maybe Text)
1292+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
12841293skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12851294 HydrationMode_Immediate -> do
12861295 -- If we're in immediate mode, we don't try to replace an existing comment,
@@ -1288,43 +1297,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12881297 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
12891298 append $ toNode t
12901299 textNodeRef <- liftIO $ newIORef t
1291− keyRef <- liftIO $ newIORef ""
1300+ keyRef <- liftIO $ newIORef Nothing
12921301 pure (pure (), textNodeRef, keyRef)
12931302 HydrationMode_Hydrating -> do
12941303 doc <- askDocument
12951304 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
12961305 keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
1297− let go key0 mLastNode = do
1298− parent <- askParent
1299− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
1300− DOM.castTo DOM.Comment node >>= \case
1306+ let
1307+ go Nothing _ = do
1308+ tn <- createTextNode doc ("" :: Text)
1309+ insertAfterPreviousNode tn
1310+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1311+ pure (tn, Nothing)
1312+ go (Just key0) mLastNode = do
1313+ parent <- askParent
1314+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1315+ Nothing -> go Nothing Nothing
1316+ Just node -> DOM.castTo DOM.Comment node >>= \case
13011317 Just comment -> do
1302− commentText <- Node.getTextContentUnchecked comment
1303− case T.stripPrefix (prefix <> key0) commentText of
1318+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
1319+ 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.
13041320 Just key -> do
13051321 -- Replace the comment with an (invisible) text node
13061322 tn <- createTextNode doc ("" :: Text)
13071323 Node.replaceChild_ parent tn comment
1308− pure (tn, key)
1324+ pure (tn, Just key)
13091325 Nothing -> do
1310− go key0 (Just node)
1326+ go (Just key0) (Just node)
13111327 Nothing -> do
1312− go 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
1328+ go (Just key0) (Just node)
1329+ switchComment = do
1330+ key0 <- liftIO $ readIORef key0Ref
1331+ (tn, key) <- go key0 =<< getPreviousNode
1332+ setPreviousNode $ Just $ toNode tn
1333+ liftIO $ do
1334+ writeIORef textNodeRef tn
1335+ writeIORef keyRef key
13201336 pure (switchComment, textNodeRef, keyRef)
13211337
13221338{-# INLINABLE skipToReplaceStart #-}
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 Text)
1324−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
1339+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))
1340+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
13251341
13261342{-# INLINABLE skipToReplaceEnd #-}
1327−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)
1343+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)
13281344skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
13291345
13301346instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
@@ -2250,7 +2266,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22502266 Touchend -> getTouchEvent
22512267 Touchcancel -> getTouchEvent
22522268 Mousewheel -> return ()
2253− Wheel -> return ()
2269+ Wheel -> getWheelEvent
22542270
22552271{-# INLINABLE defaultDomWindowEventHandler #-}
22562272defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2300,7 +2316,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
23002316 Touchend -> getTouchEvent
23012317 Touchcancel -> getTouchEvent
23022318 Mousewheel -> return ()
2303− Wheel -> return ()
2319+ Wheel -> getWheelEvent
23042320
23052321{-# INLINABLE withIsEvent #-}
23062322withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2618,6 +2634,26 @@ getTouchEvent = do
26182634 , _touchEventResult_touches = touches
26192635 }
26202636
2637+{-# INLINABLE getWheelEvent #-}
2638+getWheelEvent :: EventM e WheelEvent WheelEventResult
2639+getWheelEvent = do
2640+ e <- event
2641+ dx :: Double <- WheelEvent.getDeltaX e
2642+ dy :: Double <- WheelEvent.getDeltaY e
2643+ dz :: Double <- WheelEvent.getDeltaZ e
2644+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2645+ return $ WheelEventResult
2646+ { _wheelEventResult_deltaX = dx
2647+ , _wheelEventResult_deltaY = dy
2648+ , _wheelEventResult_deltaZ = dz
2649+ , _wheelEventResult_deltaMode = case deltaMode of
2650+ 0 -> DeltaPixel
2651+ 1 -> DeltaLine
2652+ 2 -> DeltaPage
2653+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
2654+ _ -> error "getWheelEvent: impossible encoding"
2655+ }
2656+
26212657instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26222658 {-# INLINABLE sample #-}
26232659 sample = lift . sample