@@ -0,0 +1,1190 @@
1+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE DefaultSignatures #-}
6+{-# LANGUAGE DeriveGeneric #-}
7+{-# LANGUAGE EmptyDataDecls #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE GADTs #-}
11+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12+{-# LANGUAGE LambdaCase #-}
13+{-# LANGUAGE MultiParamTypeClasses #-}
14+{-# LANGUAGE OverloadedStrings #-}
15+{-# LANGUAGE PolyKinds #-}
16+{-# LANGUAGE RankNTypes #-}
17+{-# LANGUAGE RecursiveDo #-}
18+{-# LANGUAGE ScopedTypeVariables #-}
19+{-# LANGUAGE StandaloneDeriving #-}
20+#ifdef USE_TEMPLATE_HASKELL
21+{-# LANGUAGE TemplateHaskell #-}
23+{-# LANGUAGE TypeFamilies #-}
24+{-# LANGUAGE TypeOperators #-}
25+{-# LANGUAGE UndecidableInstances #-}
27+{-# LANGUAGE ForeignFunctionInterface #-}
28+{-# LANGUAGE JavaScriptFFI #-}
30+module Reflex.Dom.Builder.Hydration
31+ ( EventTriggerRef (..)
32+ , HydrationDomBuilderEnv (..)
33+ , HydrationDomBuilderT (..)
35+ , runHydrationDomBuilderT
40+ , deleteBetweenExclusive
41+ , extractBetweenExclusive
44+ , SupportsHydrationDomBuilder
46+ , collectUpToGivenParent
47+ , EventFilterTriggerRef (..)
50+ , GhcjsDomHandler (..)
51+ , GhcjsDomHandler1 (..)
53+ , GhcjsEventFilter (..)
56+ , GhcjsEventSpec (..)
58+ , ghcjsEventSpec_filters
59+ , ghcjsEventSpec_handler
60+ , GhcjsEventHandler (..)
61+#ifndef USE_TEMPLATE_HASKELL
65+ , ChildReadyState (..)
66+ , ChildReadyStateInt (..)
70+ , defaultDomEventHandler
71+ , defaultDomWindowEventHandler
79+ , traverseDMapWithKeyWithAdjust'
80+ , hoistTraverseWithKeyWithAdjust
81+ , traverseIntMapWithKeyWithAdjust'
82+ , hoistTraverseIntMapWithKeyWithAdjust
85+import Foreign.JavaScript.TH
86+import Reflex.Adjustable.Class
87+import Reflex.Class as Reflex
88+import qualified Reflex.Spider.Internal as Spider
89+import Reflex.Dom.Builder.Class
90+import Reflex.Dom.Builder.Immediate hiding (askParent, append, extractBetweenExclusive, extractUpTo, collectUpToGivenParent, askEvents, wrap, makeElement, textNodeInternal, commentNodeInternal, wrapDomEvent, mkHasFocus, insertBefore, deleteBetweenExclusive, traverseIntMapWithKeyWithAdjust', traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, deleteUpTo, collectUpTo, hoistTraverseIntMapWithKeyWithAdjust, drawChildUpdate, subscribeDomEvent)
92+import Reflex.Host.Class
93+import qualified Reflex.Patch.DMap as PatchDMap
94+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
95+import Reflex.PerformEvent.Class
96+import Reflex.PostBuild.Class
97+import Reflex.TriggerEvent.Base hiding (askEvents)
98+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)
99+import Reflex.TriggerEvent.Class
101+import Control.Concurrent
102+import Control.Lens hiding (element, ix)
103+import Control.Monad.Exception
104+import Control.Monad.Primitive
105+import Control.Monad.Reader
106+import Control.Monad.Ref
107+#ifndef USE_TEMPLATE_HASKELL
108+import Data.Functor.Contravariant (phantom)
110+import Data.Bitraversable
112+import Data.Dependent.Map (DMap)
113+import qualified Data.Dependent.Map as DMap
114+import Data.Dependent.Sum
115+import Data.Functor.Compose
116+import Data.Functor.Constant
117+import Data.Functor.Misc
118+import Data.Functor.Product
120+import qualified Data.Map as Map
122+import Data.Monoid hiding (Product)
123+import Data.Some (Some)
124+import qualified Data.Some as Some
125+import Data.Text (Text)
126+import qualified Data.Text as T
127+import GHC.Generics (Generic)
128+import qualified GHCJS.DOM as DOM
129+import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
130+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
131+import qualified GHCJS.DOM.Element as Element
132+import qualified GHCJS.DOM.Event as Event
133+import qualified GHCJS.DOM.GlobalEventHandlers as Events
134+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
135+import GHCJS.DOM.EventM (EventM, event, on)
136+import qualified GHCJS.DOM.EventM as DOM
137+import qualified GHCJS.DOM.FileList as FileList
138+import qualified GHCJS.DOM.HTMLInputElement as Input
139+import qualified GHCJS.DOM.HTMLSelectElement as Select
140+import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
141+import GHCJS.DOM.MouseEvent
142+import qualified GHCJS.DOM.Touch as Touch
143+import qualified GHCJS.DOM.TouchEvent as TouchEvent
144+import qualified GHCJS.DOM.TouchList as TouchList
145+import GHCJS.DOM.Node (appendChild_, getChildNodes, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)
146+import qualified GHCJS.DOM.Node as DOM (insertBefore_)
147+import qualified GHCJS.DOM.Node as Node
148+import qualified GHCJS.DOM.NodeList as NodeList
149+import GHCJS.DOM.Types
150+ (liftJSM, askJSM, runJSM, JSM, MonadJSM,
151+ FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
152+ ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)
153+import qualified GHCJS.DOM.Types as DOM
154+import GHCJS.DOM.UIEvent
155+import GHCJS.DOM.KeyboardEvent as KeyboardEvent
156+import qualified GHCJS.DOM.Window as Window
157+import Language.Javascript.JSaddle (call, eval, jsg, js1)
158+import Data.IntMap.Strict (IntMap)
159+import qualified Data.IntMap.Strict as IntMap
160+import Data.FastMutableIntMap (PatchIntMap (..))
161+import qualified Data.FastMutableIntMap as FastMutableIntMap
162+import System.IO.Unsafe (unsafePerformIO)
164+import Reflex.Requester.Base
165+import Reflex.Requester.Class
166+import Foreign.JavaScript.Internal.Utils
168+#ifndef ghcjs_HOST_OS
169+import GHCJS.DOM.Types (MonadJSM (..))
171+instance MonadJSM m => MonadJSM (HydrationDomBuilderT t m) where
172+ liftJSM' = HydrationDomBuilderT . liftJSM'
175+data HydrationDomSpace
177+data HydrationEventSpec (er :: EventTag -> *) = HydrationEventSpec deriving (Generic)
179+instance Default (HydrationEventSpec er)
181+instance DomSpace HydrationDomSpace where
182+ type EventSpec HydrationDomSpace = GhcjsEventSpec
183+ type RawDocument HydrationDomSpace = DOM.Document
184+ type RawTextNode HydrationDomSpace = ()
185+ type RawCommentNode HydrationDomSpace = ()
186+ type RawElement HydrationDomSpace = ()
187+ type RawFile HydrationDomSpace = DOM.File
188+ type RawInputElement HydrationDomSpace = ()
189+ type RawTextAreaElement HydrationDomSpace = ()
190+ type RawSelectElement HydrationDomSpace = ()
191+ addEventSpecFlags _ en f es = es
192+ { _ghcjsEventSpec_filters =
193+ let f' = Just . GhcjsEventFilter . \case
194+ Nothing -> \evt -> do
195+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
196+ return (f mEventResult, return mEventResult)
197+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
198+ (oldFlags, oldContinuation) <- oldFilter evt
199+ mEventResult <- oldContinuation
200+ let newFlags = oldFlags <> f mEventResult
201+ return (newFlags, return mEventResult)
202+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
204+-- addEventSpecFlags _ _ _ _ = HydrationEventSpec
207+ - Fence off `prerender` and totally replace immediately
208+ - Fence off `runWithReplace` and hydrate at postBuild
209+ - Otherwise hydrate at build time, skipping elements without SSR attribute, stripping the attrs as we go
212+data HydrationDomBuilderEnv t m
213+ = HydrationDomBuilderEnv { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document
214+ , _hydrationDomBuilderEnv_parent :: {-# UNPACK #-} !Node
215+ , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered
216+ , _hydrationDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
217+ , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode) -- In hydration mode?
218+ , _hydrationDomBuilderEnv_hydrationNode :: {-# UNPACK #-} !(IORef (Maybe Node)) -- Hydration node index
219+ , _hydrationDomBuilderEnv_hydrationResult :: {-# UNPACK #-} !(IORef [Behavior t (m ())])
220+ , _hydrationDomBuilderEnv_prerenderDepth :: {-# UNPACK #-} !(IORef Word)
221+ , _hydrationDomBuilderEnv_eventChan :: {-# UNPACK #-} !(Chan [DSum (EventTriggerRef t) TriggerInvocation])
224+newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (RequesterT t JSM Identity (TriggerEventT t m)) a }
225+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
226+#if MIN_VERSION_base(4,9,1)
227+ , MonadAsyncException
231+instance PrimMonad m => PrimMonad (HydrationDomBuilderT x m) where
232+ type PrimState (HydrationDomBuilderT x m) = PrimState m
233+ primitive = lift . primitive
235+instance MonadTrans (HydrationDomBuilderT t) where
236+ lift = HydrationDomBuilderT . lift . lift . lift
238+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT t m) where
239+ withRenderHook hook (HydrationDomBuilderT a) = do
240+ e <- HydrationDomBuilderT ask
241+ HydrationDomBuilderT $ lift $ withRequesting $ \rsp -> do
242+ (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp
243+ return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)
244+ requestDomAction = HydrationDomBuilderT . lift . requestingIdentity
245+ requestDomAction_ = HydrationDomBuilderT . lift . requesting_
247+{-# INLINABLE runHydrationDomBuilderT #-}
248+runHydrationDomBuilderT
251+ , MonadReflexCreateTrigger t m
253+ , MonadJSM (Performable m)
257+ => HydrationDomBuilderT t m a
258+ -> HydrationDomBuilderEnv t m
259+-- -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
261+runHydrationDomBuilderT (HydrationDomBuilderT a) env =
262+ flip runTriggerEventT (_hydrationDomBuilderEnv_eventChan env) $ do
263+ rec (x, req) <- runRequesterT (runReaderT a env) rsp
264+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $
265+ traverseRequesterData (\r -> Identity <$> r) rm
268+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do
269+ v <- synchronously x
272+instance Monad m => HasDocument (HydrationDomBuilderT t m) where
273+ {-# INLINABLE askDocument #-}
274+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document
276+{-# INLINABLE askParent #-}
277+askParent :: Monad m => HydrationDomBuilderT t m Node
278+askParent = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
280+{-# INLINABLE askEvents #-}
281+askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
282+askEvents = HydrationDomBuilderT . lift . lift $ TriggerEventT.askEvents
284+localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a
285+localEnv f = HydrationDomBuilderT . local f . unHydrationDomBuilderT
287+{-# INLINABLE append #-}
288+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT t m ()
291+ liftJSM $ appendChild_ p n
295+ = HydrationMode_Hydrating
296+ | HydrationMode_Immediate
297+ deriving (Eq, Ord, Show)
299+getHydrationMode :: MonadIO m => HydrationDomBuilderT t m HydrationMode
300+getHydrationMode = do
301+ ref <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationMode
302+ liftIO $ readIORef ref
304+{-# INLINABLE textNodeInternal #-}
305+textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Text
306+textNodeInternal !t = makeNodeInternal (askDocument >>= \doc -> liftJSM $ createTextNode doc t) DOM.Text
308+{-# INLINABLE commentNodeInternal #-}
309+commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Comment
310+commentNodeInternal !t = makeNodeInternal (askDocument >>= \doc -> liftJSM $ createComment doc t) DOM.Comment
312+{-# INLINABLE makeNodeInternal #-}
313+makeNodeInternal :: (MonadJSM m, IsNode node) => HydrationDomBuilderT t m node -> (DOM.JSVal -> node) -> HydrationDomBuilderT t m node
314+makeNodeInternal mkNode constructor = do
317+ getHydrationMode >>= \case
318+ HydrationMode_Immediate -> do
319+ liftIO $ print $ "Not in hydration mode, creating node"
323+ HydrationMode_Hydrating -> do
324+ lastHydrationNodeRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationNode
325+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
326+ let go mLastNode = do
327+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
328+ DOM.castTo constructor node >>= \case
330+ liftIO $ putStrLn $ "Wrong node type, skipping"
333+ liftIO $ print $ "Using existing node"
335+ n <- go lastHydrationNode
336+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)
339+-- skipToCommentId "prerender-start" (liftJSM $ createComment doc "rerender-start") $ \new -> \case
340+-- Nothing -> void $ append $ toNode new
341+-- Just node -> void $ liftJSM $ Node.replaceChild parent new node
343+-- | s and e must both be children of the same node and s must precede e;
344+-- all nodes between s and e will be removed, but s and e will not be removed
345+deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
346+deleteBetweenExclusive s e = liftJSM $ do
347+ df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
348+ extractBetweenExclusive df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
350+-- | s and e must both be children of the same node and s must precede e; all
351+-- nodes between s and e will be moved into the given DocumentFragment, but s
352+-- and e will not be moved
353+extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
354+extractBetweenExclusive df s e = liftJSM $ do
355+ f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text)
356+ void $ call f f (df, s, e)
358+-- | s and e must both be children of the same node and s must precede e;
359+-- s and all nodes between s and e will be removed, but e will not be removed
360+{-# INLINABLE deleteUpTo #-}
361+deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
363+ df <- createDocumentFragment =<< getOwnerDocumentUnchecked s
364+ extractUpTo df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant
366+extractUpTo :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
368+--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04)
369+foreign import javascript unsafe
370+ "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"
371+ extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()
372+extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e)
374+extractUpTo df s e = liftJSM $ do
375+ f <- eval ("(function(df,s,e){ var x = s; var y; for(;;) { y = x['nextSibling']; df['appendChild'](x); if(e===y) { break; } x = y; } })" :: Text)
376+ void $ call f f (df, s, e)
379+type SupportsHydrationDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, Adjustable t m, PrimMonad m, PerformEvent t m, MonadJSM (Performable m))
381+{-# INLINABLE collectUpTo #-}
382+collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment
384+ currentParent <- getParentNodeUnchecked e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
385+ collectUpToGivenParent currentParent s e
387+{-# INLINABLE collectUpToGivenParent #-}
388+collectUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment
389+collectUpToGivenParent currentParent s e = do
390+ doc <- getOwnerDocumentUnchecked currentParent
391+ df <- createDocumentFragment doc
395+{-# INLINABLE wrap #-}
397+ :: forall m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m)
398+ => Chan [DSum (EventTriggerRef t) TriggerInvocation]
399+ -> RawElement GhcjsDomSpace
400+ -> RawElementConfig er t HydrationDomSpace
401+-- -> m (Event t (DMap (WrapArg er EventName) Identity))
402+ -> m (EventSelector t (WrapArg er EventName))
403+wrap events e cfg = do
404+ liftIO $ putStrLn $ "called wrap"
405+ forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
406+ Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
407+ Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
408+ eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
409+ triggerRef <- liftIO $ newIORef Nothing
410+ _ <- elementOnEventName en e $ do --TODO: Something safer than this cast
412+ (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt
413+ when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
414+ case _eventFlags_propagation flags of
415+ Propagation_Continue -> return ()
416+ Propagation_Stop -> withIsEvent en DOM.stopPropagation
417+ Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
418+ mv <- liftJSM k --TODO: Only do this when the event is subscribed
419+ liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]
420+ return $ en :=> EventFilterTriggerRef triggerRef
422+ let h :: GhcjsEventHandler er
423+ !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
426+ newFanEventWithTrigger $ \(WrapArg en) t ->
427+ case DMap.lookup en eventTriggerRefs of
428+ Just (EventFilterTriggerRef r) -> do
429+ writeIORef r $ Just t
431+ writeIORef r Nothing
432+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
434+ mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
436+ Nothing -> return ()
437+ Just v -> liftIO $ do
438+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
439+ ref <- newIORef $ Just t
440+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])
444+{-# INLINABLE makeElement #-}
445+makeElement :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m) => Text -> ElementConfig er t HydrationDomSpace -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), DOM.Element)
446+makeElement elementTag cfg child = do
449+ let buildElement = do
450+ e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
451+ Nothing -> createElement doc elementTag
452+ Just ens -> createElementNS doc (Just ens) elementTag
453+ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
454+ Nothing -> setAttribute e n v
455+ Just ans -> setAttributeNS e (Just ans) n v
457+ -- TODO: prerender needs completely replacing
458+ e <- makeNodeInternal buildElement DOM.Element
459+ -- Run the child builder with updated parent and previous sibling references
460+ childNode <- liftIO $ newIORef Nothing
461+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = toNode e, _hydrationDomBuilderEnv_hydrationNode = childNode }) child
463+ env <- HydrationDomBuilderT ask
464+ (ese, fire) <- newTriggerEvent
465+ let beh = pure $ void . flip runHydrationDomBuilderT env $ do
466+ es <- wrap events e $ extractRawElementConfig cfg
468+ hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult
469+ liftIO $ modifyIORef' hydrationResultRef (beh :)
470+ collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click))
471+ let evts = fan collapsed
472+ return ((Element evts (), result), e)
474+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT t m) where
475+ notReadyUntil e = do
477+ env <- HydrationDomBuilderT ask
478+ let unreadyChildren = _hydrationDomBuilderEnv_unreadyChildren env
479+ liftIO $ modifyIORef' unreadyChildren succ
481+ old <- liftIO $ readIORef unreadyChildren
483+ liftIO $ writeIORef unreadyChildren $! new
484+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction env
485+ requestDomAction_ $ ready <$ eOnce
487+ env <- HydrationDomBuilderT ask
488+ let unreadyChildren = _hydrationDomBuilderEnv_unreadyChildren env
489+ liftIO $ modifyIORef' unreadyChildren succ
491+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT t m) where
492+ type DomBuilderSpace (HydrationDomBuilderT t m) = HydrationDomSpace
493+ {-# INLINABLE textNode #-}
494+ textNode (TextNodeConfig initialContents mSetContents) = do
495+ n <- textNodeInternal initialContents
496+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
497+ return $ TextNode ()
498+ {-# INLINABLE commentNode #-}
499+ commentNode (CommentNodeConfig initialContents mSetContents) = do
500+ n <- commentNodeInternal initialContents
501+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents
502+ return $ CommentNode ()
503+ {-# INLINABLE element #-}
504+ element elementTag cfg child = fst <$> makeElement elementTag cfg child
505+ {-# INLINABLE inputElement #-}
506+ inputElement cfg = do
507+ ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
508+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
509+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue
510+ v0 <- Input.getValue domInputElement
511+ let getMyValue = Input.getValue domInputElement
512+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
513+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of
514+ Nothing -> return never
515+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
516+ Input.setValue domInputElement v'
517+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
518+ v <- holdDyn v0 $ leftmost
519+ [ valueChangedBySetValue
522+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg
523+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do
524+ Input.getChecked domInputElement
525+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of
526+ Nothing -> return never
527+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do
528+ oldChecked <- Input.getChecked domInputElement
529+ Input.setChecked domInputElement newChecked
530+ return $ if newChecked /= oldChecked
531+ then Just newChecked
533+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
534+ [ fmapMaybe id checkedChangedBySetChecked
535+ , checkedChangedByUI
537+ let initialFocus = False --TODO: Is this correct?
538+ hasFocus <- holdDyn initialFocus $ leftmost
539+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
540+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
542+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do
543+ mfiles <- Input.getFiles domInputElement
544+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs
545+ maybe (return []) getMyFiles mfiles
546+ checked <- holdUniqDyn c
547+ return $ InputElement
548+ { _inputElement_value = v
549+ , _inputElement_checked = checked
550+ , _inputElement_checkedChange = checkedChangedByUI
551+ , _inputElement_input = valueChangedByUI
552+ , _inputElement_hasFocus = hasFocus
553+ , _inputElement_element = e
554+ , _inputElement_raw = ()--domInputElement
555+ , _inputElement_files = files
557+ {-# INLINABLE textAreaElement #-}
558+ textAreaElement cfg = do --TODO
559+ ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
560+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
561+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue
562+ v0 <- TextArea.getValue domTextAreaElement
563+ let getMyValue = TextArea.getValue domTextAreaElement
564+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
565+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of
566+ Nothing -> return never
567+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
568+ TextArea.setValue domTextAreaElement v'
569+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
570+ v <- holdDyn v0 $ leftmost
571+ [ valueChangedBySetValue
574+ hasFocus <- mkHasFocus e
575+ return $ TextAreaElement
576+ { _textAreaElement_value = v
577+ , _textAreaElement_input = valueChangedByUI
578+ , _textAreaElement_hasFocus = hasFocus
579+ , _textAreaElement_element = e
580+ , _textAreaElement_raw = ()--domTextAreaElement
582+ {-# INLINABLE selectElement #-}
583+ selectElement cfg child = do
584+ ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
585+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
586+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue
587+ v0 <- Select.getValue domSelectElement
588+ let getMyValue = Select.getValue domSelectElement
589+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
590+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of
591+ Nothing -> return never
592+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do
593+ Select.setValue domSelectElement v'
594+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
595+ v <- holdDyn v0 $ leftmost
596+ [ valueChangedBySetValue
599+ hasFocus <- mkHasFocus e
600+ let wrapped = SelectElement
601+ { _selectElement_value = v
602+ , _selectElement_change = valueChangedByUI
603+ , _selectElement_hasFocus = hasFocus
604+ , _selectElement_element = e
605+ , _selectElement_raw = ()--domSelectElement
607+ return (wrapped, result)
608+ placeRawElement _ = return () -- append . toNode
609+ wrapRawElement () _ = return $ Element (EventSelector $ const never) ()
612+ = FragmentState_Unmounted
613+ | FragmentState_Mounted (DOM.Text, DOM.Text)
615+data HydrationDomFragment = HydrationDomFragment
616+ { _hydrationDomFragment_document :: DOM.DocumentFragment
617+ , _hydrationDomFragment_state :: IORef FragmentState
620+extractFragment :: MonadJSM m => HydrationDomFragment -> m ()
621+extractFragment fragment = do
622+ state <- liftIO $ readIORef $ _hydrationDomFragment_state fragment
624+ FragmentState_Unmounted -> return ()
625+ FragmentState_Mounted (before, after) -> do
626+ extractBetweenExclusive (_hydrationDomFragment_document fragment) before after
627+ liftIO $ writeIORef (_hydrationDomFragment_state fragment) FragmentState_Unmounted
629+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT t m) where
630+ type DomFragment (HydrationDomBuilderT t m) = HydrationDomFragment
631+ buildDomFragment w = do
632+ df <- createDocumentFragment =<< askDocument
633+ result <- flip localEnv w $ \env -> env
634+ { _hydrationDomBuilderEnv_parent = toNode df
636+ state <- liftIO $ newIORef FragmentState_Unmounted
637+ return (HydrationDomFragment df state, result)
638+ mountDomFragment fragment setFragment = do
640+ extractFragment fragment
641+ before <- textNodeInternal ("" :: Text)
642+ appendChild_ parent $ _hydrationDomFragment_document fragment
643+ after <- textNodeInternal ("" :: Text)
644+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
645+ requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
646+ extractFragment previousFragment
647+ extractFragment childFragment
648+ insertBefore (_hydrationDomFragment_document childFragment) after
649+ liftIO $ writeIORef (_hydrationDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
650+ liftIO $ writeIORef (_hydrationDomFragment_state fragment) $ FragmentState_Mounted (before, after)
652+skipToCommentId :: MonadJSM m => Text -> HydrationDomBuilderT t m (DOM.Comment, Text)
653+skipToCommentId prefix = do
656+ lastHydrationNodeRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationNode
657+ lastHydrationNode <- liftIO $ readIORef lastHydrationNodeRef
658+ let go mLastNode = do
659+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
660+ DOM.castTo DOM.Comment node >>= \case
662+ commentText <- Node.getTextContentUnchecked comment
663+ case T.stripPrefix prefix commentText of
664+ Just key -> pure (comment, key)
666+ liftIO $ putStrLn $ "Bad key in comment, skipping"
669+ commentText <- Node.getTextContentUnchecked node
670+ liftIO $ putStrLn $ "Not a comment, skipping"
671+ liftIO $ putStrLn commentText
673+ (a, key) <- go lastHydrationNode
674+ liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode a)
677+skipToReplaceStart :: MonadJSM m => HydrationDomBuilderT t m (DOM.Comment, Text)
678+skipToReplaceStart = skipToCommentId "replace-start"
680+skipToReplaceEnd :: MonadJSM m => Text -> HydrationDomBuilderT t m DOM.Comment
681+skipToReplaceEnd key = fmap fst $ skipToCommentId $ "replace-end" <> key
683+instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ref m ~ IORef, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m) => Adjustable t (HydrationDomBuilderT t m) where
684+ {-# INLINABLE runWithReplace #-}
685+ runWithReplace a0 a' = do
686+ initialEnv <- HydrationDomBuilderT ask
687+ (before, beforeKey) <- skipToReplaceStart
688+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv
689+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
690+ haveEverBeenReady <- liftIO $ newIORef False
691+ currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM
692+ let myCommitAction = do
693+ liftIO (readIORef haveEverBeenReady) >>= \case
696+ liftIO $ writeIORef haveEverBeenReady True
697+ old <- liftIO $ readIORef parentUnreadyChildren
699+ liftIO $ writeIORef parentUnreadyChildren $! new
700+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
701+ -- We draw 'after' in this roundabout way to avoid using MonadFix
704+ after <- skipToReplaceEnd beforeKey
705+ let drawInitialChild = do
706+ liftIO $ putStrLn "drawInitialChild"
707+ df <- createDocumentFragment doc
708+ unreadyChildren <- liftIO $ newIORef 0
709+ hydrationNode <- liftIO $ newIORef Nothing
710+ hydrationResult <- liftIO $ newIORef []
711+ localHydrationMode <- liftIO $ newIORef HydrationMode_Immediate
712+ result <- runReaderT (unHydrationDomBuilderT a0) initialEnv
713+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
714+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
715+ , _hydrationDomBuilderEnv_hydrationNode = hydrationNode
716+ , _hydrationDomBuilderEnv_parent = toNode df
717+ , _hydrationDomBuilderEnv_hydrationMode = localHydrationMode
719+ liftIO $ readIORef unreadyChildren >>= \case
720+ 0 -> writeIORef haveEverBeenReady True
721+ _ -> modifyIORef' parentUnreadyChildren succ
722+ liftIO $ putStrLn "drawInitialChild: end"
724+ a'' <- numberOccurrences a'
725+ (result0, child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
726+ df <- createDocumentFragment doc
727+ unreadyChildren <- liftIO $ newIORef 0
728+ let commitAction = do
729+ c <- liftIO $ readIORef currentCohort
730+ when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this
731+ deleteBetweenExclusive before after
732+ insertBefore df after
733+ liftIO $ writeIORef currentCohort cohortId
735+ hydrationNode <- liftIO $ newIORef (Just $ toNode before)
736+ h <- liftIO $ readIORef hydrating
737+ let child' = runReaderT (unHydrationDomBuilderT child) $ initialEnv
738+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
739+ , _hydrationDomBuilderEnv_commitAction = commitAction
740+ , _hydrationDomBuilderEnv_hydrationNode = hydrationNode
741+ , _hydrationDomBuilderEnv_parent = toNode df
743+ uc <- liftIO $ readIORef unreadyChildren
745+ HydrationMode_Hydrating -> pure Nothing
746+ HydrationMode_Immediate -> Just <$> child'
747+ let commitActionToRunNow = if uc == 0
748+ then Just $ commitAction
749+ else Nothing -- A child will run it when unreadyChildren is decremented to 0
750+ commitActionToRunNow' = if h == HydrationMode_Hydrating then Nothing else commitActionToRunNow
751+ hydrationAction = if h == HydrationMode_Hydrating then Just child' else Nothing
752+ return (hydrationAction, commitActionToRunNow', result)
753+ let drawInitialChild' = do
754+ unreadyChildren <- liftIO $ newIORef 0
755+ hydrationNode <- liftIO $ newIORef (Just $ toNode before)
756+ result <- runReaderT (unHydrationDomBuilderT a0) initialEnv
757+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
758+ , _hydrationDomBuilderEnv_commitAction = myCommitAction
759+ , _hydrationDomBuilderEnv_hydrationNode = hydrationNode
762+ env <- HydrationDomBuilderT ask
763+ let f :: RequesterT t JSM Identity (TriggerEventT t m) x -> m ()
764+ f = void . flip runHydrationDomBuilderT env . HydrationDomBuilderT . lift
765+ beh <- hold (f drawInitialChild') (fmapMaybe (\(h,_,_) -> f <$> h) child')
766+ hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult
767+ liftIO $ modifyIORef' hydrationResultRef (beh :)
768+ requestDomAction_ $ fmapMaybe (\(_,c,_) -> c) child'
769+ return (result0, fmapMaybe (\(_,_,r) -> r) child')
771+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
772+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'
773+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
774+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'
775+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
776+ traverseDMapWithKeyWithAdjustWithMove = do
777+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
778+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
779+ new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
780+ PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
781+ readIORef sRef >>= \case
782+ ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
783+ ChildReadyState_Unready _ -> do
784+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
785+ return $ PatchDMapWithMove.From_Insert $ Constant sRef
786+ PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
787+ PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
788+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
789+ deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
790+ writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
791+ return $ Constant ()
792+ p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
793+ _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
794+ return $ applyAlways p' old
795+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
796+ let p = unPatchDMapWithMove p_
797+ phsBefore <- liftIO $ readIORef placeholders
798+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
799+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
800+ collectIfMoved k e = do
801+ let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
802+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
803+ case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
805+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
806+ return $ Constant Nothing
808+ Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
809+ collected <- DMap.traverseWithKey collectIfMoved p
810+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
811+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
812+ placeFragment k e = do
813+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
814+ case PatchDMapWithMove._nodeInfo_from e of
815+ PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
816+ df `insertBefore` nextPlaceholder
817+ PatchDMapWithMove.From_Delete -> do
819+ PatchDMapWithMove.From_Move fromKey -> do
820+ Just (Constant mdf) <- return $ DMap.lookup fromKey collected
821+ mapM_ (`insertBefore` nextPlaceholder) mdf
822+ return $ Constant ()
823+ mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time
824+ liftIO $ writeIORef placeholders $! phsAfter
826+{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}
827+traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))
828+traverseDMapWithKeyWithAdjust' = do
829+ let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
830+ let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
831+ new k (ComposeMaybe m) = ComposeMaybe <$> case m of
832+ Nothing -> return Nothing
833+ Just (Compose (_, _, sRef, _)) -> do
834+ readIORef sRef >>= \case
835+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
836+ ChildReadyState_Unready _ -> do
837+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
838+ return $ Just $ Constant sRef
839+ delete _ (Constant sRef) = do
840+ writeIORef sRef $ ChildReadyState_Unready Nothing
841+ return $ Constant ()
842+ p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
843+ _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
844+ return $ applyAlways p' old
845+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
846+ phs <- liftIO $ readIORef placeholders
847+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
848+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
849+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
850+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
851+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
852+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
854+{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}
855+traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> HydrationDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> HydrationDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))
856+traverseIntMapWithKeyWithAdjust' = do
857+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
858+ let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
860+ Nothing -> return Nothing
861+ Just (_, _, sRef, _) -> do
862+ readIORef sRef >>= \case
863+ ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready
864+ ChildReadyStateInt_Unready _ -> do
865+ writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
868+ writeIORef sRef $ ChildReadyStateInt_Unready Nothing
870+ p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner
871+ _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old
872+ return $ applyAlways p' old
873+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do
874+ phs <- liftIO $ readIORef placeholders
875+ forM_ (IntMap.toList p) $ \(k, mv) -> do
876+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
877+ let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
878+ forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
879+ forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder
880+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs
882+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
883+hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
889+ , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
892+ => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
895+ -> RequesterT t JSM Identity (TriggerEventT t m) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
896+ ) -- ^ The base monad's traversal
897+ -> (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
898+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
899+ -> (IntMap.Key -> v -> HydrationDomBuilderT t m v')
902+ -> HydrationDomBuilderT t m (IntMap v', Event t (p v'))
903+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do
904+ initialEnv <- HydrationDomBuilderT ask
905+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
906+ pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
907+ haveEverBeenReady <- liftIO $ newIORef False
908+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
909+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
910+ let applyDomUpdate p = do
911+ applyDomUpdate_ placeholders lastPlaceholderRef p
913+ liftIO $ writeIORef pendingChange $! mempty
915+ liftIO (readIORef haveEverBeenReady) >>= \case
918+ liftIO $ writeIORef haveEverBeenReady True
919+ old <- liftIO $ readIORef parentUnreadyChildren
921+ liftIO $ writeIORef parentUnreadyChildren $! new
922+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
923+ markChildReady :: IORef ChildReadyStateInt -> JSM ()
924+ markChildReady childReadyState = do
925+ liftIO (readIORef childReadyState) >>= \case
926+ ChildReadyStateInt_Ready -> return ()
927+ ChildReadyStateInt_Unready countedAt -> do
928+ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
930+ Nothing -> return ()
931+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set
932+ (oldUnready, p) <- liftIO $ readIORef pendingChange
933+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null
934+ let newUnready = IntMap.delete k oldUnready
935+ liftIO $ writeIORef pendingChange (newUnready, p)
936+ when (IntMap.null newUnready) $ do
938+ (children0, children') <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
939+ let processChild k (_, _, sRef, _) = do
940+ readIORef sRef >>= \case
941+ ChildReadyStateInt_Ready -> return Nothing
942+ ChildReadyStateInt_Unready _ -> do
943+ writeIORef sRef $ ChildReadyStateInt_Unready $ Just k
945+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0
946+ liftIO $ if IntMap.null initialUnready
947+ then writeIORef haveEverBeenReady True
949+ modifyIORef' parentUnreadyChildren succ
950+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
951+ let result0 = IntMap.map (\(_, _, _, v) -> v) children0
952+ placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
953+ result' = ffor children' $ fmap $ \(_, _, _, r) -> r
954+ liftIO $ writeIORef placeholders $! placeholders0
955+ _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
956+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
957+ requestDomAction_ $ ffor children' $ \p -> do
958+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange
959+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready
960+ let !newP = p <> oldP
961+ liftIO $ writeIORef pendingChange (newUnready, newP)
962+ when (IntMap.null newUnready) $ do
964+ return (result0, result')
966+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
967+hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
976+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
977+ , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
978+ , Patch (p k (Constant Int))
981+ (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))
984+ -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))
985+ ) -- ^ The base monad's traversal
986+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
987+ -> (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
988+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
989+ -> (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))
992+ -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))
993+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
994+ initialEnv <- HydrationDomBuilderT ask
995+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
996+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
997+ haveEverBeenReady <- liftIO $ newIORef False
998+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
999+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
1000+ let applyDomUpdate p = do
1001+ applyDomUpdate_ placeholders lastPlaceholderRef p
1003+ liftIO $ writeIORef pendingChange $! mempty
1005+ liftIO (readIORef haveEverBeenReady) >>= \case
1008+ liftIO $ writeIORef haveEverBeenReady True
1009+ old <- liftIO $ readIORef parentUnreadyChildren
1011+ liftIO $ writeIORef parentUnreadyChildren $! new
1012+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv
1013+ markChildReady :: IORef (ChildReadyState k) -> JSM ()
1014+ markChildReady childReadyState = do
1015+ liftIO (readIORef childReadyState) >>= \case
1016+ ChildReadyState_Ready -> return ()
1017+ ChildReadyState_Unready countedAt -> do
1018+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1020+ Nothing -> return ()
1021+ Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
1022+ (oldUnready, p) <- liftIO $ readIORef pendingChange
1023+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
1024+ let newUnready = DMap.delete k oldUnready
1025+ liftIO $ writeIORef pendingChange (newUnready, p)
1026+ when (DMap.null newUnready) $ do
1028+ (children0, children') <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1029+ let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
1030+ readIORef sRef >>= \case
1031+ ChildReadyState_Ready -> return Nothing
1032+ ChildReadyState_Unready _ -> do
1033+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
1034+ return $ Just $ Constant sRef
1035+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
1036+ liftIO $ if DMap.null initialUnready
1037+ then writeIORef haveEverBeenReady True
1039+ modifyIORef' parentUnreadyChildren succ
1040+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1041+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
1042+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
1043+ result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
1044+ liftIO $ writeIORef placeholders $! placeholders0
1045+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0
1046+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
1047+ requestDomAction_ $ ffor children' $ \p -> do
1048+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange
1049+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready
1050+ let !newP = p <> oldP
1051+ liftIO $ writeIORef pendingChange (newUnready, newP)
1052+ when (DMap.null newUnready) $ do
1053+ applyDomUpdate newP
1054+ return (result0, result')
1056+{-# INLINABLE drawChildUpdate #-}
1057+drawChildUpdate :: (MonadIO m, MonadJSM m)
1058+ => HydrationDomBuilderEnv t m
1059+ -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
1060+ -> HydrationDomBuilderT t m (v' a)
1061+ -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
1062+drawChildUpdate initialEnv markReady child = do
1063+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
1064+ unreadyChildren <- liftIO $ newIORef 0
1065+ df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv
1066+ (placeholder, result) <- runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1067+ { _hydrationDomBuilderEnv_parent = toNode df
1068+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1069+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1071+ u <- liftIO $ readIORef unreadyChildren
1072+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
1073+ return $ Compose (df, placeholder, childReadyState, result)
1075+{-# INLINABLE drawChildUpdateInt #-}
1076+drawChildUpdateInt :: (MonadIO m, MonadJSM m)
1077+ => HydrationDomBuilderEnv t m
1078+ -> (IORef ChildReadyStateInt -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
1079+ -> HydrationDomBuilderT t m v'
1080+ -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
1081+drawChildUpdateInt initialEnv markReady child = do
1082+ childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
1083+ unreadyChildren <- liftIO $ newIORef 0
1084+ df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv
1085+ (placeholder, result) <- runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
1086+ { _hydrationDomBuilderEnv_parent = toNode df
1087+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
1088+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
1090+ u <- liftIO $ readIORef unreadyChildren
1091+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1092+ return (df, placeholder, childReadyState, result)
1094+mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
1096+ let initialFocus = False --TODO: Actually get the initial focus of the element
1097+ holdDyn initialFocus $ leftmost
1098+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
1099+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
1102+insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1103+insertAfter new existing = do
1104+ p <- getParentNodeUnchecked existing
1105+ Node.getNextSibling existing >>= DOM.insertBefore_ p new
1107+insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
1108+insertBefore new existing = do
1109+ p <- getParentNodeUnchecked existing
1110+ DOM.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
1112+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where
1113+ type Performable (HydrationDomBuilderT t m) = Performable m
1114+ {-# INLINABLE performEvent_ #-}
1115+ performEvent_ e = lift $ performEvent_ e
1116+ {-# INLINABLE performEvent #-}
1117+ performEvent e = lift $ performEvent e
1119+instance PostBuild t m => PostBuild t (HydrationDomBuilderT t m) where
1120+ {-# INLINABLE getPostBuild #-}
1121+ getPostBuild = lift getPostBuild
1123+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT t m) where
1124+ {-# INLINABLE newEventWithTrigger #-}
1125+ newEventWithTrigger = lift . newEventWithTrigger
1126+ {-# INLINABLE newFanEventWithTrigger #-}
1127+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
1129+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT t m) where
1130+ {-# INLINABLE newTriggerEvent #-}
1131+ newTriggerEvent = HydrationDomBuilderT . lift . lift $ newTriggerEvent
1132+ {-# INLINABLE newTriggerEventWithOnComplete #-}
1133+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift . lift $ newTriggerEventWithOnComplete
1134+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
1135+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f
1137+instance HasJSContext m => HasJSContext (HydrationDomBuilderT t m) where
1138+ type JSContextPhantom (HydrationDomBuilderT t m) = JSContextPhantom m
1139+ askJSContext = lift askJSContext
1141+instance MonadRef m => MonadRef (HydrationDomBuilderT t m) where
1142+ type Ref (HydrationDomBuilderT t m) = Ref m
1143+ {-# INLINABLE newRef #-}
1144+ newRef = lift . newRef
1145+ {-# INLINABLE readRef #-}
1146+ readRef = lift . readRef
1147+ {-# INLINABLE writeRef #-}
1148+ writeRef r = lift . writeRef r
1150+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT t m) where
1151+ {-# INLINABLE atomicModifyRef #-}
1152+ atomicModifyRef r = lift . atomicModifyRef r
1154+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where
1155+ type JSX (HydrationDomBuilderT t m) = JSX m
1156+ liftJS = lift . liftJS
1158+{-# INLINABLE wrapDomEvent #-}
1159+wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)
1160+wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
1162+{-# INLINABLE subscribeDomEvent #-}
1163+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
1164+ -> EventM e event (Maybe a)
1165+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]
1166+ -> EventTrigger t a
1168+subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
1170+ forM_ mv $ \v -> liftIO $ do
1171+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
1172+ etr <- newIORef $ Just et
1173+ writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]
1175+instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where
1176+ {-# INLINABLE sample #-}
1177+ sample = lift . sample
1179+instance MonadHold t m => MonadHold t (HydrationDomBuilderT t m) where
1180+ {-# INLINABLE hold #-}
1181+ hold v0 v' = lift $ hold v0 v'
1182+ {-# INLINABLE holdDyn #-}
1183+ holdDyn v0 v' = lift $ holdDyn v0 v'
1184+ {-# INLINABLE holdIncremental #-}
1185+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
1186+ {-# INLINABLE buildDynamic #-}
1187+ buildDynamic a0 = lift . buildDynamic a0
1188+ {-# INLINABLE headE #-}
1189+ headE = lift . headE