@@ -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,14 @@ import Data.IntMap.Strict (IntMap)
137140import Data.Maybe
138141import Data.Monoid ((<>))
139142import Data.Some (Some(..))
143+import Data.GADT.Compare (GCompare)
144+import Data.String (IsString)
140145import Data.Text (Text)
141146import Foreign.JavaScript.Internal.Utils
142147import Foreign.JavaScript.TH
148+import GHCJS.DOM.ClipboardEvent as ClipboardEvent
143149import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
144−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
150+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
145151import GHCJS.DOM.EventM (EventM, event, on)
146152import GHCJS.DOM.KeyboardEvent as KeyboardEvent
147153import GHCJS.DOM.MouseEvent
@@ -175,6 +181,7 @@ import qualified Data.IntMap.Strict as IntMap
175181import qualified Data.Map as Map
176182import qualified Data.Text as T
177183import qualified GHCJS.DOM as DOM
184+import qualified GHCJS.DOM.DataTransfer as DataTransfer
178185import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
179186import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
180187import qualified GHCJS.DOM.Element as Element
@@ -192,6 +199,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
192199import qualified GHCJS.DOM.TouchList as TouchList
193200import qualified GHCJS.DOM.Types as DOM
194201import qualified GHCJS.DOM.Window as Window
202+import qualified GHCJS.DOM.WheelEvent as WheelEvent
195203import qualified Reflex.Patch.DMap as PatchDMap
196204import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
197205import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
@@ -318,8 +326,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
318326addHydrationStepWithSetup setup f = getHydrationMode >>= \case
319327 HydrationMode_Immediate -> pure ()
320328 HydrationMode_Hydrating -> do
321− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
322− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover
329+ s <- lift setup
323330 addHydrationStep (f s)
324331
325332-- | Add a hydration step
@@ -743,6 +750,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
743750 -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
744751 #-}
745752
753+-- | An attribute which causes hydration to skip over an element completely.
754+skipHydrationAttribute :: IsString s => s
755+skipHydrationAttribute = "data-hydration-skip"
756+
757+-- | An attribute which signals that an element should be hydrated.
758+hydratableAttribute :: IsString s => s
759+hydratableAttribute = "data-ssr"
760+
746761{-# INLINE hydrateElement #-}
747762hydrateElement
748763 :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
@@ -764,18 +779,15 @@ hydrateElement elementTag cfg child = do
764779 }
765780 result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
766781 wrapResult <- liftIO newEmptyMVar
767− let skipAttr = "data-hydration-skip" :: DOM.JSString
768− ssrAttr = "data-ssr" :: DOM.JSString
782+ let -- Determine if we should skip an element. We currently skip elements for
783+ -- two reasons:
784+ -- 1) it was not produced by a static builder which supports hydration
785+ -- 2) it is explicitly marked to be skipped
769786 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
787+ shouldSkip e = do
788+ skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
789+ hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
790+ pure $ skip || not hydratable
779791 childDom <- liftIO $ readIORef childDelayedRef
780792 let rawCfg = extractRawElementConfig cfg
781793 doc <- askDocument
@@ -791,7 +803,7 @@ hydrateElement elementTag cfg child = do
791803 Just node -> DOM.castTo DOM.Element node >>= \case
792804 Nothing -> go (Just node) -- this node is not an element, skip
793805 Just e -> shouldSkip e >>= \case
794− True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
806+ True -> go (Just node) -- this element should be skipped by hydration
795807 False -> do
796808 t <- Element.getTagName e
797809 -- TODO: check attributes?
@@ -1277,8 +1289,8 @@ hydrateComment doc t mSetContents = do
12771289skipToAndReplaceComment
12781290 :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
12791291 => Text
1280− -> IORef Text
1281− -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
1292+ -> IORef (Maybe Text)
1293+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
12821294skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12831295 HydrationMode_Immediate -> do
12841296 -- If we're in immediate mode, we don't try to replace an existing comment,
@@ -1286,43 +1298,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
12861298 t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
12871299 append $ toNode t
12881300 textNodeRef <- liftIO $ newIORef t
1289− keyRef <- liftIO $ newIORef ""
1301+ keyRef <- liftIO $ newIORef Nothing
12901302 pure (pure (), textNodeRef, keyRef)
12911303 HydrationMode_Hydrating -> do
12921304 doc <- askDocument
12931305 textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
12941306 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
1307+ let
1308+ go Nothing _ = do
1309+ tn <- createTextNode doc ("" :: Text)
1310+ insertAfterPreviousNode tn
1311+ HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
1312+ pure (tn, Nothing)
1313+ go (Just key0) mLastNode = do
1314+ parent <- askParent
1315+ maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
1316+ Nothing -> go Nothing Nothing
1317+ Just node -> DOM.castTo DOM.Comment node >>= \case
12991318 Just comment -> do
1300− commentText <- Node.getTextContentUnchecked comment
1301− case T.stripPrefix (prefix <> key0) commentText of
1319+ commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
1320+ 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.
13021321 Just key -> do
13031322 -- Replace the comment with an (invisible) text node
13041323 tn <- createTextNode doc ("" :: Text)
13051324 Node.replaceChild_ parent tn comment
1306− pure (tn, key)
1325+ pure (tn, Just key)
13071326 Nothing -> do
1308− go key0 (Just node)
1327+ go (Just key0) (Just node)
13091328 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
1329+ go (Just key0) (Just node)
1330+ switchComment = do
1331+ key0 <- liftIO $ readIORef key0Ref
1332+ (tn, key) <- go key0 =<< getPreviousNode
1333+ setPreviousNode $ Just $ toNode tn
1334+ liftIO $ do
1335+ writeIORef textNodeRef tn
1336+ writeIORef keyRef key
13181337 pure (switchComment, textNodeRef, keyRef)
13191338
13201339{-# 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 "")
1340+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))
1341+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
13231342
13241343{-# 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)
1344+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)
13261345skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
13271346
13281347instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
@@ -1614,7 +1633,7 @@ instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ra
16141633
16151634{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
16161635traverseDMapWithKeyWithAdjust'
1617− :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
1636+ :: forall s t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, GCompare k, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
16181637 => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))
16191638 -> DMap k v
16201639 -> Event t (PatchDMap k v)
@@ -1734,7 +1753,7 @@ hoistTraverseWithKeyWithAdjust
17341753 ::
17351754 ( Adjustable t m
17361755 , MonadHold t m
1737− , DMap.GCompare k
1756+ , GCompare k
17381757 , MonadIO m
17391758 , MonadJSM m
17401759 , PrimMonad m
@@ -2239,7 +2258,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22392258 Beforecopy -> return ()
22402259 Copy -> return ()
22412260 Beforepaste -> return ()
2242− Paste -> return ()
2261+ Paste -> getPasteData
22432262 Reset -> return ()
22442263 Search -> return ()
22452264 Selectstart -> return ()
@@ -2248,7 +2267,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
22482267 Touchend -> getTouchEvent
22492268 Touchcancel -> getTouchEvent
22502269 Mousewheel -> return ()
2251− Wheel -> return ()
2270+ Wheel -> getWheelEvent
22522271
22532272{-# INLINABLE defaultDomWindowEventHandler #-}
22542273defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
@@ -2289,7 +2308,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22892308 Beforecopy -> return ()
22902309 Copy -> return ()
22912310 Beforepaste -> return ()
2292− Paste -> return ()
2311+ Paste -> getPasteData
22932312 Reset -> return ()
22942313 Search -> return ()
22952314 Selectstart -> return ()
@@ -2298,7 +2317,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
22982317 Touchend -> getTouchEvent
22992318 Touchcancel -> getTouchEvent
23002319 Mousewheel -> return ()
2301− Wheel -> return ()
2320+ Wheel -> getWheelEvent
23022321
23032322{-# INLINABLE withIsEvent #-}
23042323withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
@@ -2566,6 +2585,15 @@ getMouseEventCoords = do
25662585 e <- event
25672586 bisequence (getClientX e, getClientY e)
25682587
2588+{-# INLINABLE getPasteData #-}
2589+getPasteData :: EventM e ClipboardEvent (Maybe Text)
2590+getPasteData = do
2591+ e <- event
2592+ mdt <- ClipboardEvent.getClipboardData e
2593+ case mdt of
2594+ Nothing -> return Nothing
2595+ Just dt -> Just <$> DataTransfer.getData dt ("text" :: Text)
2596+
25692597{-# INLINABLE getTouchEvent #-}
25702598getTouchEvent :: EventM e TouchEvent TouchEventResult
25712599getTouchEvent = do
@@ -2607,6 +2635,26 @@ getTouchEvent = do
26072635 , _touchEventResult_touches = touches
26082636 }
26092637
2638+{-# INLINABLE getWheelEvent #-}
2639+getWheelEvent :: EventM e WheelEvent WheelEventResult
2640+getWheelEvent = do
2641+ e <- event
2642+ dx :: Double <- WheelEvent.getDeltaX e
2643+ dy :: Double <- WheelEvent.getDeltaY e
2644+ dz :: Double <- WheelEvent.getDeltaZ e
2645+ deltaMode :: Word <- WheelEvent.getDeltaMode e
2646+ return $ WheelEventResult
2647+ { _wheelEventResult_deltaX = dx
2648+ , _wheelEventResult_deltaY = dy
2649+ , _wheelEventResult_deltaZ = dz
2650+ , _wheelEventResult_deltaMode = case deltaMode of
2651+ 0 -> DeltaPixel
2652+ 1 -> DeltaLine
2653+ 2 -> DeltaPage
2654+ -- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
2655+ _ -> error "getWheelEvent: impossible encoding"
2656+ }
2657+
26102658instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
26112659 {-# INLINABLE sample #-}
26122660 sample = lift . sample