@@ -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,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
147+import GHCJS.DOM.ClipboardEvent as ClipboardEvent
143148import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
144−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
149+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
145150import GHCJS.DOM.EventM (EventM, event, on)
146151import GHCJS.DOM.KeyboardEvent as KeyboardEvent
147152import GHCJS.DOM.MouseEvent
@@ -175,6 +180,7 @@ import qualified Data.IntMap.Strict as IntMap
175180import qualified Data.Map as Map
176181import qualified Data.Text as T
177182import qualified GHCJS.DOM as DOM
183+import qualified GHCJS.DOM.DataTransfer as DataTransfer
178184import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
179185import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
180186import qualified GHCJS.DOM.Element as Element
@@ -192,6 +198,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
192198import qualified GHCJS.DOM.TouchList as TouchList
193199import qualified GHCJS.DOM.Types as DOM
194200import qualified GHCJS.DOM.Window as Window
201+import qualified GHCJS.DOM.WheelEvent as WheelEvent
195202import qualified Reflex.Patch.DMap as PatchDMap
196203import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197204import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -318,8 +325,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
318325addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319326 HydrationMode_Immediate -> pure ()
320327 HydrationMode_Hydrating -> do
321− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
328+ s <- lift setup
323329 addHydrationStep (f s)
324330
325331-- | Add a hydration step
@@ -743,6 +749,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
743749 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
744750 #-}
745751
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+
746760{-# INLINE hydrateElement #-}
747761hydrateElement
748762 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
@@ -764,18 +778,15 @@ hydrateElement elementTag cfg child = do
764778 }
765779 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
766780 wrapResult <- liftIO newEmptyMVar
767− let skipAttr = "data-hydration-skip" :: DOM.JSString
768− 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
769785 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
786+ shouldSkip e = do
787+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
788+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
789+ pure $ skip || not hydratable
779790 childDom <- liftIO $ readIORef childDelayedRef
780791 let rawCfg = extractRawElementConfig cfg
781792 doc <- askDocument
@@ -791,7 +802,7 @@ hydrateElement elementTag cfg child = do
791802 Just node -> DOM.castTo DOM.Element node >>= \case
792803 Nothing -> go (Just node) -- this node is not an element, skip
793804 Just e -> shouldSkip e >>= \case
794− 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
795806 False -> do
796807 t <- Element.getTagName e
797808 -- TODO: check attributes?
@@ -1277,8 +1288,8 @@ hydrateComment doc t mSetContents = do
12771288skipToAndReplaceComment
12781289 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
12791290 => Text
1280− -> IORef Text
1281− -> 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))
12821293skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12831294 HydrationMode_Immediate -> do
12841295 -- If we're in immediate mode, we don't try to replace an existing comment,
@@ -1286,43 +1297,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12861297 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
12871298 append $ toNode t
12881299 textNodeRef <- liftIO $ newIORef t
1289− keyRef <- liftIO $ newIORef ""
1300+ keyRef <- liftIO $ newIORef Nothing
12901301 pure (pure (), textNodeRef, keyRef)
12911302 HydrationMode_Hydrating -> do
12921303 doc <- askDocument
12931304 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
12941305 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
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
12991317 Just comment -> do
1300− commentText <- Node.getTextContentUnchecked comment
1301− 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.
13021320 Just key -> do
13031321 -- Replace the comment with an (invisible) text node
13041322 tn <- createTextNode doc ("" :: Text)
13051323 Node.replaceChild_ parent tn comment
1306− pure (tn, key)
1324+ pure (tn, Just key)
13071325 Nothing -> do
1308− go key0 (Just node)
1326+ go (Just key0) (Just node)
13091327 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
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
13181336 pure (switchComment, textNodeRef, keyRef)
13191337
13201338{-# 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 "")
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.
13231341
13241342{-# 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)
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)
13261344skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
13271345
13281346instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
@@ -2239,7 +2257,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22392257 Beforecopy -> return ()
22402258 Copy -> return ()
22412259 Beforepaste -> return ()
2242− Paste -> return ()
2260+ Paste -> getPasteData
22432261 Reset -> return ()
22442262 Search -> return ()
22452263 Selectstart -> return ()
@@ -2248,7 +2266,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22482266 Touchend -> getTouchEvent
22492267 Touchcancel -> getTouchEvent
22502268 Mousewheel -> return ()
2251− Wheel -> return ()
2269+ Wheel -> getWheelEvent
22522270
22532271{-# INLINABLE defaultDomWindowEventHandler #-}
22542272defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2289,7 +2307,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22892307 Beforecopy -> return ()
22902308 Copy -> return ()
22912309 Beforepaste -> return ()
2292− Paste -> return ()
2310+ Paste -> getPasteData
22932311 Reset -> return ()
22942312 Search -> return ()
22952313 Selectstart -> return ()
@@ -2298,7 +2316,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22982316 Touchend -> getTouchEvent
22992317 Touchcancel -> getTouchEvent
23002318 Mousewheel -> return ()
2301− Wheel -> return ()
2319+ Wheel -> getWheelEvent
23022320
23032321{-# INLINABLE withIsEvent #-}
23042322withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2566,6 +2584,15 @@ getMouseEventCoords = do
25662584 e <- event
25672585 bisequence (getClientX e, getClientY e)
25682586
2587+{-# INLINABLE getPasteData #-}
2588+getPasteData :: EventM e ClipboardEvent (Maybe Text)
2589+getPasteData = do
2590+ e <- event
2591+ mdt <- ClipboardEvent.getClipboardData e
2592+ case mdt of
2593+ Nothing -> return Nothing
2594+ Just dt -> Just <$> DataTransfer.getData dt ("text" :: Text)
2595+
25692596{-# INLINABLE getTouchEvent #-}
25702597getTouchEvent :: EventM e TouchEvent TouchEventResult
25712598getTouchEvent = do
@@ -2607,6 +2634,26 @@ getTouchEvent = do
26072634 , _touchEventResult_touches = touches
26082635 }
26092636
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+
26102657instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26112658 {-# INLINABLE sample #-}
26122659 sample = lift . sample