0a032a1 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Replace immediate builder with hydration builder

0a032a1Tom Smalley8 years ago

reflex-dom-core/reflex-dom-core.cabal−2

compare with develop

unifiedsplit

@@ -91,7 +91,6 @@ library

91 Foreign.JavaScript.Utils

92 Reflex.Dom.Builder.Class

93 Reflex.Dom.Builder.Class.Events

94− Reflex.Dom.Builder.Hydration

95 Reflex.Dom.Builder.Immediate

94 Reflex.Dom.Builder.Immediate

96 Reflex.Dom.Builder.InputDisabled

95 Reflex.Dom.Builder.InputDisabled

97 Reflex.Dom.Builder.Static

96 Reflex.Dom.Builder.Static

@@ -103,7 +102,6 @@ library

103 Reflex.Dom.Modals.Class

102 Reflex.Dom.Modals.Class

104 Reflex.Dom.Old

103 Reflex.Dom.Old

105 Reflex.Dom.Prerender

104 Reflex.Dom.Prerender

106− Reflex.Dom.Specializations

107 Reflex.Dom.Time

105 Reflex.Dom.Time

108 Reflex.Dom.WebSocket

106 Reflex.Dom.WebSocket

109 Reflex.Dom.WebSocket.Query

107 Reflex.Dom.WebSocket.Query

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hsdeleted−1587

@@ -1,1587 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE ConstraintKinds #-}

4−{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE DeriveFunctor #-}

6−{-# LANGUAGE DeriveTraversable #-}

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 PatternGuards #-}

16−{-# LANGUAGE PolyKinds #-}

17−{-# LANGUAGE RankNTypes #-}

18−{-# LANGUAGE RecursiveDo #-}

19−{-# LANGUAGE ScopedTypeVariables #-}

20−{-# LANGUAGE TupleSections #-}

21−{-# LANGUAGE TypeFamilies #-}

22−{-# LANGUAGE TypeOperators #-}

23−{-# LANGUAGE UndecidableInstances #-}

24−#ifdef ghcjs_HOST_OS

25−{-# LANGUAGE ForeignFunctionInterface #-}

26−{-# LANGUAGE JavaScriptFFI #-}

27−#endif

28−-- | This is a builder to be used on the client side. It can be run in two modes:

29−--

30−-- 1. in "hydration mode", reusing DOM nodes already in the page (as produced

31−-- by 'Reflex.Dom.Builder.Static.renderStatic')

32−-- 2. in "immediate mode", creating and appending DOM nodes as required

33−--

34−-- In "hydration mode", the preexisting DOM __must contain__ what the builder

35−-- will expect at switchover time (the time at which parity with the static

36−-- renderer is reached, and the time after which the page is "live").

37−-- There can be extra nodes, but no missing or incorrect nodes.

38−--

39−-- For example, displaying the current time as text should be done inside

40−-- 'Reflex.Dom.Prerender.prerender' to ensure that we don't attempt to hydrate the incorrect text.

41−-- The server will prerender a text node with time A, and the client will expect

42−-- a text node with time B. Barring a miracle, time A and time B will not match,

43−-- and hydration will fail.

44−module Reflex.Dom.Builder.Hydration

45− ( EventTriggerRef (..)

46− , HydrationDomBuilderEnv (..)

47− , HydrationDomBuilderT (..)

48− , HydrationMode (..)

49− , HydrationRunnerT (..)

50− , runHydrationRunnerT

51− , localEnv

52− , addHydrationStepWithSetup

53− , addHydrationStep

54− , getHydrationMode

55− , hydrateNode

56− , getPreviousNode, setPreviousNode

57− , runHydrationDomBuilderT

58− , askEvents

59− , SupportsHydrationDomBuilder

60− -- Exported for specialization

61− , HydrationDomSpace

62− , makeElement

63− , drawChildUpdate

64− , drawChildUpdateInt

65− , ChildReadyState

66− , DomRenderHookT

67− , TraverseChild

68− , append

69− , wrap

70− , triggerBody

71− , WrapArg

72− , EventTrigger

73− , traverseIntMapWithKeyWithAdjust'

74− , hoistTraverseIntMapWithKeyWithAdjust

75− , makeNodeInternal

76− , runDomRenderHookT

77− ) where

78−

79−import Control.Concurrent

80−import Control.Exception (bracketOnError)

81−import Control.Lens (Identity(..), imapM_, iforM_, (^.))

82−import Control.Monad.Exception

83−import Control.Monad.Primitive

84−import Control.Monad.Reader

85−import Control.Monad.Ref

86−import Control.Monad.State.Strict

87−import Data.Dependent.Map (DMap)

88−import Data.Dependent.Sum

89−import Data.FastMutableIntMap (PatchIntMap (..))

90−import Data.Foldable (for_)

91−import Data.Functor.Compose

92−import Data.Functor.Constant

93−import Data.Functor.Misc

94−import Data.Functor.Product

95−import Data.IORef

96−import Data.IntMap.Strict (IntMap)

97−import Data.Maybe

98−import Data.Some (Some(..))

99−import Data.Text (Text)

100−import Data.Typeable (Typeable)

101−import Foreign.JavaScript.Internal.Utils

102−import Foreign.JavaScript.TH

103−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

104−import GHCJS.DOM.Element (removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)

105−import GHCJS.DOM.EventM (on)

106−import GHCJS.DOM.Node (appendChild_, setNodeValue, toNode)

107−import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, IsNode, Node, ToDOMString, uncheckedCastTo)

108−import Reflex.Adjustable.Class

109−import Reflex.Class as Reflex

110−import Reflex.Dom.Builder.Class

111−import Reflex.Dom.Builder.Immediate hiding (askEvents, askParent, append, wrap, makeElement, textNodeInternal, traverseIntMapWithKeyWithAdjust', traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, hoistTraverseIntMapWithKeyWithAdjust, drawChildUpdate, ChildReadyState(..))

112−import Reflex.Dynamic

113−import Reflex.Host.Class

114−import Reflex.Patch.DMapWithMove (PatchDMapWithMove(..))

115−import Reflex.Patch.MapWithMove (PatchMapWithMove(..))

116−import Reflex.PerformEvent.Class

117−import Reflex.PostBuild.Class

118−import Reflex.Requester.Base

119−import Reflex.Requester.Class

120−import Reflex.TriggerEvent.Base hiding (askEvents)

121−import Reflex.TriggerEvent.Class

122−

123−import qualified Data.Dependent.Map as DMap

124−import qualified Data.FastMutableIntMap as FastMutableIntMap

125−import qualified Data.IntMap.Strict as IntMap

126−import qualified Data.Map as Map

127−import qualified Data.Text as T

128−import qualified GHCJS.DOM as DOM

129−import qualified GHCJS.DOM.DocumentOrShadowRoot as Document

130−import qualified GHCJS.DOM.Element as Element

131−import qualified GHCJS.DOM.EventM as DOM

132−import qualified GHCJS.DOM.FileList as FileList

133−import qualified GHCJS.DOM.GlobalEventHandlers as Events

134−import qualified GHCJS.DOM.HTMLInputElement as Input

135−import qualified GHCJS.DOM.HTMLSelectElement as Select

136−import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

137−import qualified GHCJS.DOM.Node as Node

138−import qualified GHCJS.DOM.Text as DOM

139−import qualified GHCJS.DOM.Types as DOM

140−import qualified Reflex.Patch.DMap as PatchDMap

141−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

142−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

143−import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)

144−

145−#ifndef USE_TEMPLATE_HASKELL

146−import Data.Functor.Contravariant (phantom)

147−#endif

148−

149−#ifndef ghcjs_HOST_OS

150−import GHCJS.DOM.Types (MonadJSM (..))

151−

152−instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where

153− {-# INLINE liftJSM' #-}

154− liftJSM' = lift . liftJSM'

155−

156−instance MonadJSM m => MonadJSM (HydrationDomBuilderT t m) where

157− {-# INLINE liftJSM' #-}

158− liftJSM' = lift . liftJSM'

159−

160−instance MonadJSM m => MonadJSM (DomRenderHookT t m) where

161− {-# INLINE liftJSM' #-}

162− liftJSM' = lift . liftJSM'

163−#endif

164−

165−data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv

166− { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document

167− -- ^ Reference to the document

168− , _hydrationDomBuilderEnv_parent :: !(Either Node (IORef Node))

169− -- ^ This is in an IORef because in the time up to hydration we can't actually know what the

170− -- parent is - we populate this reference during the DOM traversal at hydration time

171− , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word)

172− -- ^ Number of children who still aren't fully rendered

173− , _hydrationDomBuilderEnv_commitAction :: !(JSM ())

174− -- ^ Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

175− , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)

176− -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished

177− , _hydrationDomBuilderEnv_switchover :: !(Event t ())

178− , _hydrationDomBuilderEnv_delayed :: {-# UNPACK #-} !(IORef (HydrationRunnerT t m ()))

179− }

180−

181−-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.

182−-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.

183−newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT (Maybe Node) (ReaderT Node (DomRenderHookT t m)) a }

184− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

185−#if MIN_VERSION_base(4,9,1)

186− , MonadAsyncException

187−#endif

188− )

189−

190−{-# INLINE localRunner #-}

191−localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a

192−localRunner (HydrationRunnerT m) s parent = HydrationRunnerT . lift $ local (\_ -> parent) (evalStateT m s)

193−

194−{-# INLINE runHydrationRunnerT #-}

195−runHydrationRunnerT

196− :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))

197− => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

198−runHydrationRunnerT (HydrationRunnerT m) s parent = runDomRenderHookT (runReaderT (evalStateT m s) parent)

199−

200−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where

201− {-# INLINE newEventWithTrigger #-}

202− newEventWithTrigger = lift . newEventWithTrigger

203− {-# INLINE newFanEventWithTrigger #-}

204− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

205−

206−instance MonadTrans (HydrationRunnerT t) where

207− {-# INLINE lift #-}

208− lift = HydrationRunnerT . lift . lift . lift

209−

210−instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where

211− {-# INLINE sample #-}

212− sample = lift . sample

213−

214−-- | Add a hydration step which depends on some computation that should only be

215−-- done *before* the switchover to immediate mode - this is most likely some

216−-- form of 'hold' which we want to remove after hydration is done

217−{-# INLINE addHydrationStepWithSetup #-}

218−addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT t m ()

219−addHydrationStepWithSetup setup f = getHydrationMode >>= \case

220− HydrationMode_Immediate -> pure ()

221− HydrationMode_Hydrating -> do

222− switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

223− (s, _) <- lift $ runWithReplace setup $ return () <$ switchover -- 4% more memory than above

224− addHydrationStep (f s)

225−

226−-- | Add a hydration step

227−{-# INLINE addHydrationStep #-}

228−addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT t m ()

229−addHydrationStep m = do

230− delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed

231− liftIO $ modifyIORef' delayedRef (>> m)

232−

233−-- | A monad for DomBuilder which just gets the results of children and pushes

234−-- work into an action that is delayed until after postBuild (to match the

235−-- static builder). The action runs in 'HydrationRunnerT', which performs the

236−-- DOM takeover and sets up the events, after which point this monad will

237−-- continue in the vein of 'ImmediateDomBuilderT'.

238−newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (DomRenderHookT t m) a }

239− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

240−#if MIN_VERSION_base(4,9,1)

241− , MonadAsyncException

242−#endif

243− )

244−

245−instance PrimMonad m => PrimMonad (HydrationDomBuilderT x m) where

246− type PrimState (HydrationDomBuilderT x m) = PrimState m

247− primitive = lift . primitive

248−

249−instance MonadTrans (HydrationDomBuilderT t) where

250− {-# INLINE lift #-}

251− lift = HydrationDomBuilderT . lift . lift

252−

253−-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT

254−newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }

255− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

256−#if MIN_VERSION_base(4,9,1)

257− , MonadAsyncException

258−#endif

259− )

260−

261−{-# INLINE runDomRenderHookT #-}

262−runDomRenderHookT

263− :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)

264− => DomRenderHookT t m a

265− -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

266− -> m a

267−runDomRenderHookT (DomRenderHookT a) events = do

268− flip runTriggerEventT events $ do

269− rec (result, req) <- runRequesterT a rsp

270− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $

271− traverseRequesterData (\r -> Identity <$> r) rm

272− return result

273− where

274− runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do

275− v <- synchronously x

276− void . liftIO $ f v

277−

278−instance MonadTrans (DomRenderHookT t) where

279− {-# INLINE lift #-}

280− lift = DomRenderHookT . lift . lift

281−

282−instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where

283− withRenderHook hook (DomRenderHookT a) = do

284− DomRenderHookT $ withRequesting $ \rsp -> do

285− (x, req) <- lift $ runRequesterT a $ runIdentity <$> rsp

286− return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)

287− requestDomAction = DomRenderHookT . requestingIdentity

288− requestDomAction_ = DomRenderHookT . requesting_

289−

290−instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT t m) where

291− withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT

292− requestDomAction = HydrationDomBuilderT . lift . requestDomAction

293− requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_

294−

295−instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where

296− withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT

297− requestDomAction = HydrationRunnerT . lift . lift . requestDomAction

298− requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_

299−

300−{-# INLINE runHydrationDomBuilderT #-}

301−runHydrationDomBuilderT

302− :: ( MonadFix m

303− , PerformEvent t m

304− , MonadReflexCreateTrigger t m

305− , MonadJSM m

306− , MonadJSM (Performable m)

307− , MonadRef m

308− , Ref m ~ IORef

309− )

310− => HydrationDomBuilderT t m a

311− -> HydrationDomBuilderEnv t m

312− -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

313− -> m a

314−runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)

315−

316−instance Monad m => HasDocument (HydrationDomBuilderT t m) where

317− {-# INLINE askDocument #-}

318− askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document

319−

320−{-# INLINE localEnv #-}

321−localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a

322−localEnv f = HydrationDomBuilderT . local (f $!) . unHydrationDomBuilderT

323−

324−{-# INLINE append #-}

325−append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT t m ()

326−append n = do

327− p <- getParent

328− appendChild_ p n

329− return ()

330−

331−data HydrationMode

332− = HydrationMode_Hydrating

333− | HydrationMode_Immediate

334− deriving (Eq, Ord, Show)

335−

336−{-# INLINE askParent #-}

337−askParent :: Monad m => HydrationRunnerT t m DOM.Node

338−askParent = HydrationRunnerT ask

339−

340−{-# INLINE getPreviousNode #-}

341−getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)

342−getPreviousNode = HydrationRunnerT get

343−

344−{-# INLINE setPreviousNode #-}

345−setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()

346−setPreviousNode = HydrationRunnerT . put

347−

348−{-# INLINE getParent #-}

349−getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node

350−getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)

351−

352−{-# INLINE askUnreadyChildren #-}

353−askUnreadyChildren :: Monad m => HydrationDomBuilderT t m (IORef Word)

354−askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren

355−

356−{-# INLINE askCommitAction #-}

357−askCommitAction :: Monad m => HydrationDomBuilderT t m (JSM ())

358−askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction

359−

360−{-# INLINE getHydrationMode #-}

361−getHydrationMode :: MonadIO m => HydrationDomBuilderT t m HydrationMode

362−getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)

363−

364−{-# INLINE askEvents #-}

365−askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

366−askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents

367−

368−{-# INLINE makeNodeInternal #-}

369−makeNodeInternal

370− :: forall node t m. (MonadJSM m, IsNode node, Typeable node)

371− => HydrationDomBuilderT t m node -> HydrationDomBuilderT t m node

372−makeNodeInternal mkNode = do

373− n <- mkNode

374− append $ toNode n

375− return n

376−

377−{-# INLINE hydrateNode #-}

378−-- | This function expects the existing DOM at the current hydration node to be

379−-- correct. It skips any nodes that are the wrong type, or that fail the

380−-- @check@. The previous node reference is also updated.

381−hydrateNode

382− :: (MonadJSM m, IsNode node, Typeable node)

383− => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node

384−hydrateNode check constructor = do

385− parent <- askParent

386− lastHydrationNode <- getPreviousNode

387− let go mLastNode = do

388− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

389− DOM.castTo constructor node >>= \case

390− Nothing -> go (Just node)

391− Just tn -> check tn >>= \case

392− True -> return tn

393− False -> go (Just node)

394− n <- go lastHydrationNode

395− setPreviousNode $ Just $ toNode n

396− return n

397−

398−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))

399−

400−-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself

401−{-# INLINE wrap #-}

402−wrap

403− :: forall m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m)

404− => Chan [DSum (EventTriggerRef t) TriggerInvocation]

405− -> DOM.Element

406− -> RawElementConfig er t HydrationDomSpace

407− -> m (DMap EventName (EventFilterTriggerRef t er))

408−wrap events e cfg = do

409− forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

410− Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

411− Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

412− eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

413− triggerRef <- liftIO $ newIORef Nothing

414− _ <- elementOnEventName en e $ do --TODO: Something safer than this cast

415− evt <- DOM.event

416− (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt

417− when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault

418− case _eventFlags_propagation flags of

419− Propagation_Continue -> return ()

420− Propagation_Stop -> withIsEvent en DOM.stopPropagation

421− Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation

422− mv <- liftJSM k --TODO: Only do this when the event is subscribed

423− liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]

424− return $ en :=> EventFilterTriggerRef triggerRef

425− return eventTriggerRefs

426−

427−{-# INLINE triggerBody #-}

428−triggerBody

429− :: forall er t x. DOM.JSContextRef

430− -> ElementConfig er t HydrationDomSpace

431− -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

432− -> DMap EventName (EventFilterTriggerRef t er)

433− -> DOM.Element

434− -> WrapArg er EventName x

435− -> EventTrigger t x

436− -> IO (IO ())

437−triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of

438− Just (EventFilterTriggerRef r) -> do

439− writeIORef r $ Just t

440− return $ do

441− writeIORef r Nothing

442− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

443− evt <- DOM.event

444− mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)

445− case mv of

446− Nothing -> return ()

447− Just v -> liftIO $ do

448− --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

449− ref <- newIORef $ Just t

450− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

451− where

452− -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't

453− -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up

454− handler :: GhcjsEventHandler er

455− !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec $ extractRawElementConfig cfg

456−

457−{-# INLINE makeElement #-}

458−makeElement

459− :: 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)

460− => Text

461− -> ElementConfig er t HydrationDomSpace

462− -> HydrationDomBuilderT t m a

463− -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), Either DOM.Element (IORef DOM.Element))

464−makeElement elementTag cfg child = do

465− doc <- askDocument

466− ctx <- askJSM

467− events <- askEvents

468−

469− let buildElement :: JSM DOM.Element

470− buildElement = do

471− e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

472− Nothing -> createElement doc elementTag

473− Just ens -> createElementNS doc (Just ens) elementTag

474− iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

475− Nothing -> setAttribute e n v

476− Just ans -> setAttributeNS e (Just ans) n v

477− pure e

478− ssrAttr = "data-ssr" :: DOM.JSString

479− hasSSRAttribute :: DOM.Element -> HydrationRunnerT t m Bool

480− hasSSRAttribute e = case cfg ^. namespace of

481− Nothing -> hasAttribute e ssrAttr <* removeAttribute e ssrAttr

482− Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr

483− getHydrationMode >>= \case

484− HydrationMode_Immediate -> do

485− e <- makeNodeInternal $ liftJSM buildElement

486− -- Run the child builder with updated parent and previous sibling references

487− result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child

488− eventTriggerRefs <- wrap events e $ extractRawElementConfig cfg

489− es <- newFanEventWithTrigger $ triggerBody ctx cfg events eventTriggerRefs e

490− return ((Element es (), result), Left e)

491− HydrationMode_Hydrating -> do

492− -- Schedule everything for after postBuild, except for getting the result itself

493− parent <- liftIO $ newIORef $ error "Parent not yet initialized"

494− e' <- liftIO $ newIORef $ error "makeElement: Element not yet initialized"

495− env <- HydrationDomBuilderT ask

496− childDelayedRef <- liftIO $ newIORef $ pure ()

497− let env' = env

498− { _hydrationDomBuilderEnv_parent = Right parent

499− , _hydrationDomBuilderEnv_delayed = childDelayedRef

500− }

501− result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'

502− wrapResult <- liftIO newEmptyMVar

503− let activateElement = do

504− e <- hydrateNode hasSSRAttribute DOM.Element

505− -- Update the parent node used by the children

506− liftIO $ writeIORef parent $ toNode e

507− liftIO $ writeIORef e' e

508− -- Setup events, store the result so we can wait on it later

509− refs <- wrap events e $ extractRawElementConfig cfg

510− liftIO $ putMVar wrapResult (e, refs)

511− pure $ toNode e

512− childDom <- liftIO $ readIORef childDelayedRef

513− addHydrationStep $ activateElement >>= localRunner childDom Nothing

514−

515− -- We need the EventSelector to switch to the real event handler after activation

516− es <- newFanEventWithTrigger $ \(WrapArg en) t -> do

517− cleanup <- newEmptyMVar

518− threadId <- forkIO $ do

519− -- Wait on the data we need from the delayed action

520− (e, eventTriggerRefs) <- readMVar wrapResult

521− bracketOnError

522− -- Run the setup, acquiring the cleanup action

523− (triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t)

524− -- Run the cleanup, if we have it - but only when an exception is

525− -- raised (we might get killed between acquiring the cleanup action

526− -- from 'triggerBody' and putting it in the MVar)

527− id

528− -- Try to put this action into the cleanup MVar

529− (putMVar cleanup)

530− pure $ do

531− tryReadMVar cleanup >>= \case

532− Nothing -> killThread threadId

533− Just c -> c

534−

535− let dummyElement = error "makeElement: DOM.Element"

536− return ((Element es dummyElement, result), Right e')

537−

538−{-# INLINE textNodeInternal #-}

539−textNodeInternal :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t) => Text -> Maybe (Event t Text) -> HydrationDomBuilderT t m DOM.Text

540−textNodeInternal !t mSetContents = getHydrationMode >>= \case

541− HydrationMode_Immediate -> do

542− n <- makeNodeInternal (askDocument >>= \doc -> createTextNode doc t)

543− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

544− pure n

545− HydrationMode_Hydrating -> do

546− addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do

547− n <- hydrateTextNode =<< sample currentText

548− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

549− pure $ error "textNodeInternal: DOM.Text"

550−

551−-- | The static builder mashes adjacent text nodes into one node: we check the

552−-- text content of each node we come to, comparing it to the content we

553−-- expect. We also have a special case for empty text nodes - we always create

554−-- the and add them after the previous node reference.

555−{-# INLINE hydrateTextNode #-}

556−hydrateTextNode :: MonadJSM m => Text -> HydrationRunnerT t m DOM.Text

557−hydrateTextNode t@"" = do

558− doc <- Node.getOwnerDocumentUnchecked =<< askParent

559− tn <- createTextNode doc t

560− insertAfterPreviousNode tn

561− pure tn

562−hydrateTextNode t = do

563− n <- join $ go <$> askParent <*> getPreviousNode

564− setPreviousNode $ Just $ toNode n

565− return n

566− where

567− go parent mLastNode = do

568− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

569− DOM.castTo DOM.Text node >>= \case

570− Nothing -> go parent $ Just node

571− Just originalNode -> do

572− originalText <- Node.getTextContentUnchecked originalNode

573− case T.stripPrefix t originalText of

574− Just "" -> return originalNode

575− Just _ -> do

576− -- If we have the right prefix, we split the text node into a node containing the

577− -- required text and a subsequent sibling node containing the rest of the text.

578− DOM.splitText_ originalNode $ fromIntegral $ T.length t

579− return originalNode

580− Nothing -> go parent $ Just $ toNode originalNode

581−

582−

583−{-# INLINE commentNodeInternal #-}

584−commentNodeInternal :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, ToDOMString contents, Reflex t, Adjustable t m) => contents -> Maybe (Event t contents) -> HydrationDomBuilderT t m DOM.Comment

585−commentNodeInternal !t mSetContents = getHydrationMode >>= \case

586− HydrationMode_Immediate -> do

587− n <- makeNodeInternal (askDocument >>= \doc -> createComment doc t)

588− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

589− pure n

590− HydrationMode_Hydrating -> do

591− addHydrationStep $ do

592− n <- hydrateNode (const $ pure True) DOM.Comment

593− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

594− pure $ error "commentNodeInternal: DOM.Comment"

595−

596−-- | We leave markers in the static builder as comments, and rip these comments

597−-- out at hydration time, replacing them with empty text nodes.

598−{-# INLINE skipToAndReplaceComment #-}

599−skipToAndReplaceComment

600− :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m)

601− => Text

602− -> IORef Text

603− -> HydrationDomBuilderT t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

604−skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

605− HydrationMode_Immediate -> do

606− -- If we're in immediate mode, we don't try to replace an existing comment,

607− -- and just return a dummy key

608− t <- textNodeInternal ("" :: Text) Nothing

609− append $ toNode t

610− textNodeRef <- liftIO $ newIORef t

611− keyRef <- liftIO $ newIORef ""

612− pure (pure (), textNodeRef, keyRef)

613− HydrationMode_Hydrating -> do

614− doc <- askDocument

615− textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"

616− keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"

617− let go key0 mLastNode = do

618− parent <- askParent

619− node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

620− DOM.castTo DOM.Comment node >>= \case

621− Just comment -> do

622− commentText <- Node.getTextContentUnchecked comment

623− case T.stripPrefix (prefix <> key0) commentText of

624− Just key -> do

625− -- Replace the comment with an (invisible) text node

626− tn <- createTextNode doc ("" :: Text)

627− Node.replaceChild_ parent tn comment

628− pure (tn, key)

629− Nothing -> do

630− go key0 (Just node)

631− Nothing -> do

632− go key0 (Just node)

633− switchComment = do

634− key0 <- liftIO $ readIORef key0Ref

635− (tn, key) <- go key0 =<< getPreviousNode

636− setPreviousNode $ Just $ toNode tn

637− liftIO $ do

638− writeIORef textNodeRef tn

639− writeIORef keyRef key

640− pure (switchComment, textNodeRef, keyRef)

641−

642−{-# INLINE skipToReplaceStart #-}

643−skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m) => HydrationDomBuilderT t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

644−skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")

645−

646−{-# INLINE skipToReplaceEnd #-}

647−skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m) => IORef Text -> HydrationDomBuilderT t m (HydrationRunnerT t m (), IORef DOM.Text)

648−skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

649−

650−instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT t m) where

651− notReadyUntil e = do

652− eOnce <- headE e

653− unreadyChildren <- askUnreadyChildren

654− commitAction <- askCommitAction

655− liftIO $ modifyIORef' unreadyChildren succ

656− let ready = do

657− old <- liftIO $ readIORef unreadyChildren

658− let new = pred old

659− liftIO $ writeIORef unreadyChildren $! new

660− when (new == 0) commitAction

661− requestDomAction_ $ ready <$ eOnce

662− notReady = do

663− unreadyChildren <- askUnreadyChildren

664− liftIO $ modifyIORef' unreadyChildren succ

665−

666−data HydrationDomSpace

667−

668−instance DomSpace HydrationDomSpace where

669− type EventSpec HydrationDomSpace = GhcjsEventSpec

670− type RawDocument HydrationDomSpace = DOM.Document

671− type RawTextNode HydrationDomSpace = ()

672− type RawCommentNode HydrationDomSpace = ()

673− type RawElement HydrationDomSpace = ()

674− type RawInputElement HydrationDomSpace = ()

675− type RawTextAreaElement HydrationDomSpace = ()

676− type RawSelectElement HydrationDomSpace = ()

677− addEventSpecFlags _ en f es = es

678− { _ghcjsEventSpec_filters =

679− let f' = Just . GhcjsEventFilter . \case

680− Nothing -> \evt -> do

681− mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)

682− return (f mEventResult, return mEventResult)

683− Just (GhcjsEventFilter oldFilter) -> \evt -> do

684− (oldFlags, oldContinuation) <- oldFilter evt

685− mEventResult <- oldContinuation

686− let newFlags = oldFlags <> f mEventResult

687− return (newFlags, return mEventResult)

688− in DMap.alter f' en $ _ghcjsEventSpec_filters es

689− }

690−

691−instance (SupportsHydrationDomBuilder t m) => DomBuilder t (HydrationDomBuilderT t m) where

692− type DomBuilderSpace (HydrationDomBuilderT t m) = HydrationDomSpace

693− {-# INLINE textNode #-}

694− textNode (TextNodeConfig initialContents mSetContents) = do

695− _ <- textNodeInternal initialContents mSetContents

696− return $ TextNode ()

697− {-# INLINE commentNode #-}

698− commentNode (CommentNodeConfig initialContents mSetContents) = do

699− _ <- commentNodeInternal initialContents mSetContents

700− return $ CommentNode ()

701− {-# INLINE element #-}

702− element elementTag cfg child = do

703− fst <$> makeElement elementTag cfg child

704− {-# INLINE inputElement #-}

705− inputElement cfg = do

706− ((e, _), domElementRef) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

707−

708− (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

709− (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

710−

711− (focusChange, triggerFocusChange) <- newTriggerEvent

712− (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent

713− (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent

714−

715− (fileChange, triggerFileChange) <- newTriggerEvent

716−

717− doc <- askDocument

718−

719− -- Expected initial value from config

720− let v0 = _inputElementConfig_initialValue cfg

721− impl :: (DomRenderHook t n, MonadJSM n) => n ()

722− impl = do

723− domElement <- either pure (liftIO . readIORef) domElementRef

724− let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

725− getValue = Input.getValue domInputElement

726−

727− -- The browser might have messed with the value, or the user could have

728− -- altered it before activation, so we set it if it isn't what we expect

729− liftJSM getValue >>= \v0' -> do

730− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

731−

732− -- Watch for user interaction and trigger event accordingly

733− requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

734−

735− for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->

736− requestDomAction_ $ ffor eSetValue $ \v' -> do

737− Input.setValue domInputElement v'

738− v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

739− liftIO $ triggerChangeBySetValue v

740−

741− let focusChange' = leftmost

742− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

743− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

744− ]

745− liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

746− requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

747−

748− Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

749− _ <- liftJSM $ domInputElement `on` Events.click $ do

750− liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement

751−

752− for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->

753− requestDomAction $ ffor eNewchecked $ \newChecked -> do

754− oldChecked <- Input.getChecked domInputElement

755− Input.setChecked domInputElement newChecked

756− when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked

757−

758− _ <- liftJSM $ domInputElement `on` Events.change $ do

759− mfiles <- Input.getFiles domInputElement

760− let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

761− liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles

762−

763− return ()

764−

765− getHydrationMode >>= \case

766− HydrationMode_Hydrating -> addHydrationStep impl

767− HydrationMode_Immediate -> impl

768−

769− checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

770− [ checkedChangedBySetChecked

771− , checkedChangedByUI

772− ]

773− checked <- holdUniqDyn checked'

774−

775− let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

776− hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange

777−

778− v <- holdDyn v0 $ leftmost

779− [ valueChangedBySetValue

780− , valueChangedByUI

781− ]

782−

783− files <- holdDyn mempty fileChange

784−

785− return $ InputElement

786− { _inputElement_value = v

787− , _inputElement_checked = checked

788− , _inputElement_checkedChange = checkedChangedByUI

789− , _inputElement_input = valueChangedByUI

790− , _inputElement_hasFocus = hasFocus

791− , _inputElement_element = e

792− , _inputElement_raw = ()

793− , _inputElement_files = files

794− }

795−

796− {-# INLINE textAreaElement #-}

797− textAreaElement cfg = do

798− ((e, _), domElementRef) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

799−

800− (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

801− (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

802−

803− (focusChange, triggerFocusChange) <- newTriggerEvent

804−

805− doc <- askDocument

806−

807− -- Expected initial value from config

808− let v0 = _textAreaElementConfig_initialValue cfg

809− impl :: (DomRenderHook t n, MonadJSM n) => n ()

810− impl = do

811− domElement <- either pure (liftIO . readIORef) domElementRef

812− let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

813− getValue = TextArea.getValue domTextAreaElement

814−

815− -- The browser might have messed with the value, or the user could have

816− -- altered it before activation, so we set it if it isn't what we expect

817− liftJSM getValue >>= \v0' -> do

818− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

819−

820− -- Watch for user interaction and trigger event accordingly

821− requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

822−

823− for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->

824− requestDomAction_ $ ffor eSetValue $ \v' -> do

825− TextArea.setValue domTextAreaElement v'

826− v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

827− liftIO $ triggerChangeBySetValue v

828−

829− let focusChange' = leftmost

830− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

831− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

832− ]

833− liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

834− requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

835−

836− getHydrationMode >>= \case

837− HydrationMode_Hydrating -> addHydrationStep impl

838− HydrationMode_Immediate -> impl

839−

840− let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

841− hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange

842−

843− v <- holdDyn v0 $ leftmost

844− [ valueChangedBySetValue

845− , valueChangedByUI

846− ]

847−

848− return $ TextAreaElement

849− { _textAreaElement_value = v

850− , _textAreaElement_input = valueChangedByUI

851− , _textAreaElement_hasFocus = hasFocus

852− , _textAreaElement_element = e

853− , _textAreaElement_raw = ()

854− }

855−

856− {-# INLINE selectElement #-}

857− selectElement cfg child = do

858− ((e, result), domElementRef) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child

859−

860− (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

861− (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

862−

863− (focusChange, triggerFocusChange) <- newTriggerEvent

864−

865− doc <- askDocument

866−

867− -- Expected initial value from config

868− let v0 = _selectElementConfig_initialValue cfg

869− impl :: (DomRenderHook t n, MonadJSM n) => n ()

870− impl = do

871− domElement <- either pure (liftIO . readIORef) domElementRef

872− let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

873− getValue = Select.getValue domSelectElement

874−

875− -- The browser might have messed with the value, or the user could have

876− -- altered it before activation, so we set it if it isn't what we expect

877− liftJSM getValue >>= \v0' -> do

878− when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

879−

880− -- Watch for user interaction and trigger event accordingly

881− requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)

882−

883− for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->

884− requestDomAction_ $ ffor eSetValue $ \v' -> do

885− Select.setValue domSelectElement v'

886− v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

887− liftIO $ triggerChangeBySetValue v

888−

889− let focusChange' = leftmost

890− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

891− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

892− ]

893− liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

894− requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

895−

896− getHydrationMode >>= \case

897− HydrationMode_Hydrating -> addHydrationStep impl

898− HydrationMode_Immediate -> impl

899−

900− let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

901− hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange

902−

903− v <- holdDyn v0 $ leftmost

904− [ valueChangedBySetValue

905− , valueChangedByUI

906− ]

907−

908− return $ (,result) $ SelectElement

909− { _selectElement_value = v

910− , _selectElement_change = valueChangedByUI

911− , _selectElement_hasFocus = hasFocus

912− , _selectElement_element = e

913− , _selectElement_raw = ()

914− }

915−

916− placeRawElement () = pure ()

917− wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()

918−

919−data FragmentState

920− = FragmentState_Unmounted

921− | FragmentState_Mounted (DOM.Text, DOM.Text)

922−

923−data HydrationDomFragment = HydrationDomFragment

924− { _hydrationDomFragment_document :: DOM.DocumentFragment

925− , _hydrationDomFragment_state :: IORef FragmentState

926− }

927−

928−extractFragment :: MonadJSM m => HydrationDomFragment -> m ()

929−extractFragment fragment = do

930− s <- liftIO $ readIORef $ _hydrationDomFragment_state fragment

931− case s of

932− FragmentState_Unmounted -> return ()

933− FragmentState_Mounted (before, after) -> do

934− extractBetweenExclusive (_hydrationDomFragment_document fragment) before after

935− liftIO $ writeIORef (_hydrationDomFragment_state fragment) FragmentState_Unmounted

936−

937−instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT t m) where

938− type DomFragment (HydrationDomBuilderT t m) = HydrationDomFragment

939− buildDomFragment w = do

940− df <- createDocumentFragment =<< askDocument

941− result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode df }) w

942− s <- liftIO $ newIORef FragmentState_Unmounted

943− return (HydrationDomFragment df s, result)

944− mountDomFragment fragment setFragment = do

945− parent <- getParent

946− extractFragment fragment

947− before <- textNodeInternal ("" :: Text) Nothing

948− appendChild_ parent $ _hydrationDomFragment_document fragment

949− after <- textNodeInternal ("" :: Text) Nothing

950− xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment

951− requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do

952− extractFragment previousFragment

953− extractFragment childFragment

954− insertBefore (_hydrationDomFragment_document childFragment) after

955− liftIO $ writeIORef (_hydrationDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

956− liftIO $ writeIORef (_hydrationDomFragment_state fragment) $ FragmentState_Mounted (before, after)

957−

958−instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where

959− runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')

960− traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m

961− traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m

962− traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m

963−

964−instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (HydrationDomBuilderT t m) where

965− {-# INLINE runWithReplace #-}

966− runWithReplace a0 a' = do

967− initialEnv <- HydrationDomBuilderT ask

968− let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv

969− (hydrateStart, before, beforeKey) <- skipToReplaceStart

970− let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

971− haveEverBeenReady <- liftIO $ newIORef False

972− currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM

973− let myCommitAction = do

974− liftIO (readIORef haveEverBeenReady) >>= \case

975− True -> return ()

976− False -> do

977− liftIO $ writeIORef haveEverBeenReady True

978− old <- liftIO $ readIORef parentUnreadyChildren

979− let new = pred old

980− liftIO $ writeIORef parentUnreadyChildren $! new

981− when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

982− -- We draw 'after' in this roundabout way to avoid using MonadFix

983− doc <- askDocument

984− parent <- getParent

985− (hydrateEnd, after) <- skipToReplaceEnd beforeKey

986− let drawInitialChild = do

987− h <- liftIO $ readIORef hydrating

988− p' <- case h of

989− HydrationMode_Hydrating -> pure parent

990− HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

991− unreadyChildren <- liftIO $ newIORef 0

992− let a0' = case h of

993− HydrationMode_Hydrating -> a0

994− HydrationMode_Immediate -> do

995− a <- a0

996− insertBefore p' =<< liftIO (readIORef after)

997− pure a

998− delayed <- case h of

999− HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()

1000− HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv

1001− result <- runReaderT (unHydrationDomBuilderT a0') initialEnv

1002− { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1003− , _hydrationDomBuilderEnv_commitAction = myCommitAction

1004− , _hydrationDomBuilderEnv_parent = Left p'

1005− , _hydrationDomBuilderEnv_delayed = delayed

1006− }

1007− dom <- case h of

1008− HydrationMode_Hydrating -> liftIO $ readIORef delayed

1009− HydrationMode_Immediate -> pure $ pure ()

1010− liftIO $ readIORef unreadyChildren >>= \case

1011− 0 -> writeIORef haveEverBeenReady True

1012− _ -> modifyIORef' parentUnreadyChildren succ

1013− return (dom, result)

1014− a'' <- numberOccurrences a'

1015− ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

1016− h <- liftIO $ readIORef hydrating

1017− p' <- case h of

1018− HydrationMode_Hydrating -> pure parent

1019− HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

1020− unreadyChildren <- liftIO $ newIORef 0

1021− let commitAction = do

1022− c <- liftIO $ readIORef currentCohort

1023− when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this

1024− !before' <- liftIO $ readIORef before

1025− !after' <- liftIO $ readIORef after

1026− deleteBetweenExclusive before' after'

1027− insertBefore p' after'

1028− liftIO $ writeIORef currentCohort cohortId

1029− myCommitAction

1030− delayed <- case h of

1031− HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()

1032− HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv

1033− result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv

1034− { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1035− , _hydrationDomBuilderEnv_commitAction = case h of

1036− HydrationMode_Hydrating -> myCommitAction

1037− HydrationMode_Immediate -> commitAction

1038− , _hydrationDomBuilderEnv_parent = Left p'

1039− , _hydrationDomBuilderEnv_delayed = delayed

1040− }

1041− dom <- case h of

1042− HydrationMode_Hydrating -> liftIO $ readIORef delayed

1043− HydrationMode_Immediate -> pure $ pure ()

1044− uc <- liftIO $ readIORef unreadyChildren

1045− let commitActionToRunNow = if uc == 0

1046− then Just $ commitAction

1047− else Nothing -- A child will run it when unreadyChildren is decremented to 0

1048− actions = case h of

1049− HydrationMode_Hydrating -> Left dom

1050− HydrationMode_Immediate -> Right commitActionToRunNow

1051− return (actions, result)

1052− let (hydrate', commitAction) = fanEither $ fmap fst child'

1053− addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do

1054− hydrateStart

1055− join $ sample contents

1056− hydrateEnd

1057− requestDomAction_ $ fmapMaybe id commitAction

1058− return (result0, snd <$> child')

1059−

1060− {-# INLINE traverseIntMapWithKeyWithAdjust #-}

1061− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'

1062− {-# INLINE traverseDMapWithKeyWithAdjust #-}

1063− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'

1064− {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

1065− traverseDMapWithKeyWithAdjustWithMove = do

1066− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do

1067− let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState (Some k)))) a)

1068− new k = PatchDMapWithMove.nodeInfoMapFromM $ \case

1069− PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete

1070− PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do

1071− readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

1072− ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete

1073− ChildReadyState_Unready _ -> do

1074− writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1075− return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)

1076− PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete

1077− PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey

1078− deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a)

1079− deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do

1080− writeIORef sRef $ ChildReadyState_Unready $ This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases

1081− return $ Constant ()

1082− p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p

1083− _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old

1084− return $ applyAlways p' old

1085− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do

1086− let p = unPatchDMapWithMove p_

1087− phsBefore <- liftIO $ readIORef placeholders

1088− let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)

1089− collectIfMoved k e = do

1090− let mThisPlaceholder = Map.lookup (This k) phsBefore -- Will be Nothing if this element wasn't present before

1091− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsBefore

1092− case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of

1093− False -> do

1094− mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

1095− return $ Constant Nothing

1096− True -> do

1097− Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder

1098− collected <- DMap.traverseWithKey collectIfMoved p

1099− let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore

1100− weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))

1101− weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_

1102− filtered :: PatchMapWithMove (Some k) DOM.Text

1103− filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of

1104− PatchMapWithMove.From_Insert (Left _hydration) -> Nothing

1105− PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate

1106− PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete

1107− PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k

1108− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)

1109− placeFragment k e = do

1110− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsAfter

1111− case PatchDMapWithMove._nodeInfo_from e of

1112− PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of

1113− Left _ -> pure ()

1114− Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

1115− PatchDMapWithMove.From_Delete -> do

1116− return ()

1117− PatchDMapWithMove.From_Move fromKey -> do

1118− Just (Constant mdf) <- return $ DMap.lookup fromKey collected

1119− mapM_ (`insertBefore` nextPlaceholder) mdf

1120− return $ Constant ()

1121− 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

1122− liftIO $ writeIORef placeholders $! phsAfter

1123−

1124−{-# INLINE traverseDMapWithKeyWithAdjust' #-}

1125−traverseDMapWithKeyWithAdjust'

1126− :: forall t m (k :: * -> *) v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadJSM m, PrimMonad m, DMap.GCompare k)

1127− => (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))

1128− -> DMap k v

1129− -> Event t (PatchDMap k v)

1130− -> HydrationDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))

1131−traverseDMapWithKeyWithAdjust' = do

1132− let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do

1133− let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)

1134− new k (ComposeMaybe m) = ComposeMaybe <$> case m of

1135− Nothing -> return Nothing

1136− Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing

1137− Just (Compose (TraverseChild (Right immediate) _)) -> do

1138− readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

1139− ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

1140− ChildReadyState_Unready _ -> do

1141− writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1142− return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)

1143− delete _ (Constant sRef) = do

1144− writeIORef sRef $ ChildReadyState_Unready Nothing

1145− return $ Constant ()

1146− p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p

1147− _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old

1148− return $ applyAlways p' old

1149− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do

1150− phs <- liftIO $ readIORef placeholders

1151− forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do

1152− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phs

1153− -- Delete old node

1154− forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do

1155− thisPlaceholder `deleteUpTo` nextPlaceholder

1156− -- Insert new node

1157− forM_ mv $ \(Compose (TraverseChild e _)) -> case e of

1158− Left _hydration -> pure ()

1159− Right immediate -> do

1160− _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

1161− let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))

1162− weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch

1163− filtered :: PatchMap (Some k) DOM.Text

1164− filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case

1165− Nothing -> Just Nothing -- deletion

1166− Just (Left _) -> Nothing

1167− Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate

1168− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs

1169−

1170−{-# INLINE traverseIntMapWithKeyWithAdjust' #-}

1171−traverseIntMapWithKeyWithAdjust'

1172− :: forall t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m)

1173− => (IntMap.Key -> v -> HydrationDomBuilderT t m v')

1174− -> IntMap v

1175− -> Event t (PatchIntMap v)

1176− -> HydrationDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))

1177−traverseIntMapWithKeyWithAdjust' = do

1178− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do

1179− let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))

1180− new k m = case m of

1181− Nothing -> return Nothing

1182− Just (TraverseChild (Left _hydration) _) -> pure Nothing

1183− Just (TraverseChild (Right immediate) _) -> do

1184− let sRef = _traverseChildImmediate_childReadyState immediate

1185− readIORef sRef >>= \case

1186− ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

1187− ChildReadyState_Unready _ -> do

1188− writeIORef sRef $ ChildReadyState_Unready $ Just k

1189− return $ Just sRef

1190− delete _ sRef = do

1191− writeIORef sRef $ ChildReadyState_Unready Nothing

1192− return ()

1193− p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner

1194− _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old

1195− return $ applyAlways p' old

1196− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do

1197− phs <- liftIO $ readIORef placeholders

1198− forM_ (IntMap.toList p) $ \(k, mv) -> do

1199− let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs

1200− -- Delete old node

1201− forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

1202− -- Insert new node

1203− forM_ mv $ \(TraverseChild e _) -> case e of

1204− Left _hydration -> pure ()

1205− Right immediate -> do

1206− _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

1207− let filtered :: PatchIntMap DOM.Text

1208− filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case

1209− Nothing -> Just Nothing -- deletion

1210− Just tc

1211− | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate

1212− | otherwise -> Nothing

1213− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs

1214−

1215−data ChildReadyState a

1216− = ChildReadyState_Ready

1217− | ChildReadyState_Unready !(Maybe a)

1218− deriving (Show, Read, Eq, Ord)

1219−

1220−insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()

1221−insertAfterPreviousNode node = do

1222− parent <- askParent

1223− nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode

1224− Node.insertBefore_ parent node nextNode

1225− setPreviousNode $ Just $ toNode node

1226−

1227−{-# INLINE hoistTraverseWithKeyWithAdjust #-}

1228−hoistTraverseWithKeyWithAdjust

1229− ::

1230− ( Adjustable t m

1231− , MonadHold t m

1232− , DMap.GCompare k

1233− , MonadIO m

1234− , MonadJSM m

1235− , PrimMonad m

1236− , MonadFix m

1237− , Patch (p k v)

1238− , Patch (p k (Constant Int))

1239− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)

1240− , Patch (p k (Compose (TraverseChild t m (Some k)) v'))

1241− , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')

1242− , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))

1243− )

1244− => (forall vv vv'.

1245− (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))

1246− -> DMap k vv

1247− -> Event t (p k vv)

1248− -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))

1249− -- ^ The base monad's traversal

1250− -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')

1251− -- ^ A way of mapping over the patch type

1252− -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))

1253− -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state

1254− -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())

1255− -- ^ Apply a patch to the DOM

1256− -> (forall a. k a -> v a -> HydrationDomBuilderT t m (v' a))

1257− -> DMap k v

1258− -> Event t (p k v)

1259− -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))

1260−hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

1261− doc <- askDocument

1262− initialEnv <- HydrationDomBuilderT ask

1263− let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

1264− pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty

1265− haveEverBeenReady <- liftIO $ newIORef False

1266− placeholders <- liftIO $ newIORef Map.empty

1267− lastPlaceholder <- createTextNode doc ("" :: Text)

1268− let applyDomUpdate p = do

1269− applyDomUpdate_ placeholders lastPlaceholder p

1270− markSelfReady

1271− liftIO $ writeIORef pendingChange $! mempty

1272− markSelfReady = do

1273− liftIO (readIORef haveEverBeenReady) >>= \case

1274− True -> return ()

1275− False -> do

1276− liftIO $ writeIORef haveEverBeenReady True

1277− old <- liftIO $ readIORef parentUnreadyChildren

1278− let new = pred old

1279− liftIO $ writeIORef parentUnreadyChildren $! new

1280− when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

1281− markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()

1282− markChildReady childReadyState = do

1283− liftIO (readIORef childReadyState) >>= \case

1284− ChildReadyState_Ready -> return ()

1285− ChildReadyState_Unready countedAt -> do

1286− liftIO $ writeIORef childReadyState ChildReadyState_Ready

1287− case countedAt of

1288− Nothing -> return ()

1289− Just (This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set

1290− (oldUnready, p) <- liftIO $ readIORef pendingChange

1291− when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null

1292− let newUnready = DMap.delete k oldUnready

1293− liftIO $ writeIORef pendingChange (newUnready, p)

1294− when (DMap.null newUnready) $ do

1295− applyDomUpdate p

1296− (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))

1297− <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

1298− let processChild k (Compose (TraverseChild e _)) = case e of

1299− Left _ -> pure $ ComposeMaybe Nothing

1300− Right immediate -> ComposeMaybe <$> do

1301− readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

1302− ChildReadyState_Ready -> return Nothing

1303− ChildReadyState_Unready _ -> do

1304− writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1305− return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)

1306− initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0

1307− liftIO $ if DMap.null initialUnready

1308− then writeIORef haveEverBeenReady True

1309− else do

1310− modifyIORef' parentUnreadyChildren succ

1311− writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

1312− getHydrationMode >>= \case

1313− HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

1314− dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children

1315− phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm

1316− liftIO $ writeIORef placeholders $! phs

1317− insertAfterPreviousNode lastPlaceholder

1318− HydrationMode_Immediate -> do

1319− let activate i = do

1320− append $ toNode $ _traverseChildImmediate_fragment i

1321− pure $ _traverseChildImmediate_placeholder i

1322− phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0

1323− liftIO $ writeIORef placeholders $! phs

1324− append $ toNode lastPlaceholder

1325− requestDomAction_ $ ffor children' $ \p -> do

1326− (oldUnready, oldP) <- liftIO $ readIORef pendingChange

1327− newUnready <- liftIO $ updateChildUnreadiness p oldUnready

1328− let !newP = p <> oldP

1329− liftIO $ writeIORef pendingChange (newUnready, newP)

1330− when (DMap.null newUnready) $ do

1331− applyDomUpdate newP

1332− let result0 = DMap.map (_traverseChild_result . getCompose) children0

1333− result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose

1334− return (result0, result')

1335−

1336−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}

1337−hoistTraverseIntMapWithKeyWithAdjust ::

1338− ( Adjustable t m

1339− , MonadHold t m

1340− , MonadJSM m

1341− , MonadFix m

1342− , PrimMonad m

1343− , Monoid (p (TraverseChild t m Int v'))

1344− , Functor p

1345− , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())

1346− , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')

1347− , Patch (p (HydrationRunnerT t m ()))

1348− , Patch (p (TraverseChild t m Int v'))

1349− )

1350− => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))

1351− -> IntMap v

1352− -> Event t (p v)

1353− -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))

1354− -- ^ The base monad's traversal

1355− -> (p (TraverseChild t m Int v')

1356− -> IntMap (IORef (ChildReadyState Int))

1357− -> IO (IntMap (IORef (ChildReadyState Int))))

1358− -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state

1359− -> (IORef (IntMap DOM.Text)

1360− -> DOM.Text

1361− -> p (TraverseChild t m Int v')

1362− -> JSM ())

1363− -- ^ Apply a patch to the DOM

1364− -> (IntMap.Key -> v -> HydrationDomBuilderT t m v')

1365− -> IntMap v

1366− -> Event t (p v)

1367− -> HydrationDomBuilderT t m (IntMap v', Event t (p v'))

1368−hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

1369− doc <- askDocument

1370− initialEnv <- HydrationDomBuilderT ask

1371− let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

1372− pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty

1373− haveEverBeenReady <- liftIO $ newIORef False

1374− placeholders <- liftIO $ newIORef IntMap.empty

1375− lastPlaceholder <- createTextNode doc ("" :: Text)

1376− let applyDomUpdate p = do

1377− applyDomUpdate_ placeholders lastPlaceholder p

1378− markSelfReady

1379− liftIO $ writeIORef pendingChange $! mempty

1380− markSelfReady = do

1381− liftIO (readIORef haveEverBeenReady) >>= \case

1382− True -> return ()

1383− False -> do

1384− liftIO $ writeIORef haveEverBeenReady True

1385− old <- liftIO $ readIORef parentUnreadyChildren

1386− let new = pred old

1387− liftIO $ writeIORef parentUnreadyChildren $! new

1388− when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

1389− markChildReady :: IORef (ChildReadyState Int) -> JSM ()

1390− markChildReady childReadyState = do

1391− liftIO (readIORef childReadyState) >>= \case

1392− ChildReadyState_Ready -> return ()

1393− ChildReadyState_Unready countedAt -> do

1394− liftIO $ writeIORef childReadyState ChildReadyState_Ready

1395− case countedAt of

1396− Nothing -> return ()

1397− Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set

1398− (oldUnready, p) <- liftIO $ readIORef pendingChange

1399− when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null

1400− let newUnready = IntMap.delete k oldUnready

1401− liftIO $ writeIORef pendingChange (newUnready, p)

1402− when (IntMap.null newUnready) $ do

1403− applyDomUpdate p

1404− (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))

1405− <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

1406− let processChild k (TraverseChild e _) = case e of

1407− Left _ -> pure Nothing

1408− Right immediate -> do

1409− readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

1410− ChildReadyState_Ready -> return Nothing

1411− ChildReadyState_Unready _ -> do

1412− writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k

1413− return $ Just (_traverseChildImmediate_childReadyState immediate)

1414− initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0

1415− liftIO $ if IntMap.null initialUnready

1416− then writeIORef haveEverBeenReady True

1417− else do

1418− modifyIORef' parentUnreadyChildren succ

1419− writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

1420− getHydrationMode >>= \case

1421− HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

1422− dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children

1423− phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm

1424− liftIO $ writeIORef placeholders $! phs

1425− insertAfterPreviousNode lastPlaceholder

1426− HydrationMode_Immediate -> do

1427− let activate i = do

1428− append $ toNode $ _traverseChildImmediate_fragment i

1429− pure $ _traverseChildImmediate_placeholder i

1430− phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0

1431− liftIO $ writeIORef placeholders $! phs

1432− append $ toNode lastPlaceholder

1433− requestDomAction_ $ ffor children' $ \p -> do

1434− (oldUnready, oldP) <- liftIO $ readIORef pendingChange

1435− newUnready <- liftIO $ updateChildUnreadiness p oldUnready

1436− let !newP = p <> oldP

1437− liftIO $ writeIORef pendingChange (newUnready, newP)

1438− when (IntMap.null newUnready) $ do

1439− applyDomUpdate newP

1440− let result0 = IntMap.map _traverseChild_result children0

1441− result' = ffor children' $ fmap $ _traverseChild_result

1442− return (result0, result')

1443−

1444−data TraverseChildImmediate k = TraverseChildImmediate

1445− { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment

1446− -- ^ Child is appended to this fragment

1447− , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text

1448− -- ^ Placeholder reference

1449− , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))

1450− }

1451−

1452−newtype TraverseChildHydration t m = TraverseChildHydration

1453− { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text

1454− -- ^ Action to run at switchover, returns the placeholder

1455− }

1456−

1457−data TraverseChild t m k a = TraverseChild

1458− { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))

1459− , _traverseChild_result :: !a

1460− } deriving Functor

1461−

1462−{-# INLINE drawChildUpdate #-}

1463−drawChildUpdate :: (MonadJSM m, Reflex t)

1464− => HydrationDomBuilderEnv t m

1465− -> (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

1466− -> HydrationDomBuilderT t m (f a)

1467− -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)

1468−drawChildUpdate initialEnv markReady child = do

1469− let doc = _hydrationDomBuilderEnv_document initialEnv

1470− unreadyChildren <- liftIO $ newIORef 0

1471− liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case

1472− HydrationMode_Hydrating -> do

1473− childDelayedRef <- liftIO $ newIORef $ pure ()

1474− result <- runReaderT (unHydrationDomBuilderT child) initialEnv

1475− { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1476− , _hydrationDomBuilderEnv_delayed = childDelayedRef

1477− }

1478− childDelayed <- liftIO $ readIORef childDelayedRef

1479− return $ Compose $ TraverseChild

1480− { _traverseChild_result = result

1481− , _traverseChild_mode = Left TraverseChildHydration

1482− { _traverseChildHydration_delayed = do

1483− placeholder <- createTextNode doc ("" :: Text)

1484− insertAfterPreviousNode placeholder

1485− childDelayed

1486− pure placeholder

1487− }

1488− }

1489− HydrationMode_Immediate -> do

1490− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

1491− df <- createDocumentFragment doc

1492− placeholder <- createTextNode doc ("" :: Text)

1493− Node.appendChild_ df placeholder

1494− result <- runReaderT (unHydrationDomBuilderT child) initialEnv

1495− { _hydrationDomBuilderEnv_parent = Left $ toNode df

1496− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1497− , _hydrationDomBuilderEnv_commitAction = markReady childReadyState

1498− }

1499− u <- liftIO $ readIORef unreadyChildren

1500− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

1501− return $ Compose $ TraverseChild

1502− { _traverseChild_result = result

1503− , _traverseChild_mode = Right TraverseChildImmediate

1504− { _traverseChildImmediate_fragment = df

1505− , _traverseChildImmediate_placeholder = placeholder

1506− , _traverseChildImmediate_childReadyState = childReadyState

1507− }

1508− }

1509−

1510−{-# INLINE drawChildUpdateInt #-}

1511−drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)

1512− => HydrationDomBuilderEnv t m

1513− -> (IORef (ChildReadyState k) -> JSM ())

1514− -> HydrationDomBuilderT t m v

1515− -> DomRenderHookT t m (TraverseChild t m k v)

1516−drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)

1517−

1518−instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where

1519− type Performable (HydrationDomBuilderT t m) = Performable m

1520− {-# INLINE performEvent_ #-}

1521− performEvent_ e = lift $ performEvent_ e

1522− {-# INLINE performEvent #-}

1523− performEvent e = lift $ performEvent e

1524−

1525−instance PostBuild t m => PostBuild t (HydrationDomBuilderT t m) where

1526− {-# INLINE getPostBuild #-}

1527− getPostBuild = lift getPostBuild

1528−

1529−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT t m) where

1530− {-# INLINE newEventWithTrigger #-}

1531− newEventWithTrigger = lift . newEventWithTrigger

1532− {-# INLINE newFanEventWithTrigger #-}

1533− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

1534−

1535−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT t m) where

1536− {-# INLINE newTriggerEvent #-}

1537− newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent

1538− {-# INLINE newTriggerEventWithOnComplete #-}

1539− newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete

1540− {-# INLINE newEventWithLazyTriggerWithOnComplete #-}

1541− newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f

1542−

1543−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where

1544− {-# INLINE newTriggerEvent #-}

1545− newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent

1546− {-# INLINE newTriggerEventWithOnComplete #-}

1547− newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete

1548− {-# INLINE newEventWithLazyTriggerWithOnComplete #-}

1549− newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f

1550−

1551−instance HasJSContext m => HasJSContext (HydrationDomBuilderT t m) where

1552− type JSContextPhantom (HydrationDomBuilderT t m) = JSContextPhantom m

1553− askJSContext = lift askJSContext

1554−

1555−instance MonadRef m => MonadRef (HydrationDomBuilderT t m) where

1556− type Ref (HydrationDomBuilderT t m) = Ref m

1557− {-# INLINE newRef #-}

1558− newRef = lift . newRef

1559− {-# INLINE readRef #-}

1560− readRef = lift . readRef

1561− {-# INLINE writeRef #-}

1562− writeRef r = lift . writeRef r

1563−

1564−instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT t m) where

1565− {-# INLINE atomicModifyRef #-}

1566− atomicModifyRef r = lift . atomicModifyRef r

1567−

1568−instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where

1569− type JSX (HydrationDomBuilderT t m) = JSX m

1570− liftJS = lift . liftJS

1571−

1572−instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where

1573− {-# INLINE sample #-}

1574− sample = lift . sample

1575−

1576−instance MonadHold t m => MonadHold t (HydrationDomBuilderT t m) where

1577− {-# INLINE hold #-}

1578− hold v0 v' = lift $ hold v0 v'

1579− {-# INLINE holdDyn #-}

1580− holdDyn v0 v' = lift $ holdDyn v0 v'

1581− {-# INLINE holdIncremental #-}

1582− holdIncremental v0 v' = lift $ holdIncremental v0 v'

1583− {-# INLINE buildDynamic #-}

1584− buildDynamic a0 = lift . buildDynamic a0

1585− {-# INLINE headE #-}

1586− headE = lift . headE

1587−

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+1575−562

@@ -2,7 +2,8 @@

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE ConstraintKinds #-}

4{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE DefaultSignatures #-}

5+{-# LANGUAGE DeriveFunctor #-}

6+{-# LANGUAGE DeriveTraversable #-}

6{-# LANGUAGE EmptyDataDecls #-}

7{-# LANGUAGE EmptyDataDecls #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

@@ -11,14 +12,15 @@

11{-# LANGUAGE LambdaCase #-}

12{-# LANGUAGE LambdaCase #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE OverloadedStrings #-}

14{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE PatternGuards #-}

14{-# LANGUAGE PolyKinds #-}

16{-# LANGUAGE PolyKinds #-}

15{-# LANGUAGE RankNTypes #-}

17{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE RecursiveDo #-}

18{-# LANGUAGE RecursiveDo #-}

17{-# LANGUAGE ScopedTypeVariables #-}

19{-# LANGUAGE ScopedTypeVariables #-}

18−{-# LANGUAGE StandaloneDeriving #-}

19#ifdef USE_TEMPLATE_HASKELL

20#ifdef USE_TEMPLATE_HASKELL

20{-# LANGUAGE TemplateHaskell #-}

21{-# LANGUAGE TemplateHaskell #-}

21#endif

22#endif

23+{-# LANGUAGE TupleSections #-}

22{-# LANGUAGE TypeFamilies #-}

24{-# LANGUAGE TypeFamilies #-}

23{-# LANGUAGE TypeOperators #-}

25{-# LANGUAGE TypeOperators #-}

24{-# LANGUAGE UndecidableInstances #-}

26{-# LANGUAGE UndecidableInstances #-}

@@ -26,184 +28,332 @@

26{-# LANGUAGE ForeignFunctionInterface #-}

28{-# LANGUAGE ForeignFunctionInterface #-}

27{-# LANGUAGE JavaScriptFFI #-}

29{-# LANGUAGE JavaScriptFFI #-}

28#endif

30#endif

31+-- | This is a builder to be used on the client side. It can be run in two modes:

32+--

33+-- 1. in "hydration mode", reusing DOM nodes already in the page (as produced

34+-- by 'Reflex.Dom.Builder.Static.renderStatic')

35+-- 2. in "immediate mode", creating and appending DOM nodes as required

36+--

37+-- In "hydration mode", the preexisting DOM __must contain__ what the builder

38+-- will expect at switchover time (the time at which parity with the static

39+-- renderer is reached, and the time after which the page is "live").

40+-- There can be extra nodes, but no missing or incorrect nodes.

41+--

42+-- For example, displaying the current time as text should be done inside

43+-- 'Reflex.Dom.Prerender.prerender' to ensure that we don't attempt to hydrate the incorrect text.

44+-- The server will prerender a text node with time A, and the client will expect

45+-- a text node with time B. Barring a miracle, time A and time B will not match,

46+-- and hydration will fail.

29module Reflex.Dom.Builder.Immediate

47module Reflex.Dom.Builder.Immediate

30− ( EventTriggerRef (..)

48+ ( HydrationDomBuilderT (..)

31− , ImmediateDomBuilderEnv (..)

49+ , HydrationDomBuilderEnv (..)

50+ , HydrationMode (..)

51+ , HydrationRunnerT (..)

52+ , runHydrationRunnerT

32− , ImmediateDomBuilderT (..)

53+ , ImmediateDomBuilderT

33− , runImmediateDomBuilderT

54+ , runHydrationDomBuilderT

55+

56+ , getHydrationMode

57+ , addHydrationStep

58+ , addHydrationStepWithSetup

59+ , setPreviousNode

60+

34− , askParent

61+ , askParent

35− , askEvents

62+ , askEvents

36− , append

63+ , append

37− , textNodeInternal

64+ , textNodeInternal

38− , deleteBetweenExclusive

65+ , deleteBetweenExclusive

39− , extractBetweenExclusive

66+ , extractBetweenExclusive

40− , deleteUpTo

67+ , deleteUpTo

41− , extractUpTo

68+ , extractUpTo

42− , SupportsImmediateDomBuilder

69+ , SupportsHydrationDomBuilder

43− , collectUpTo

70+ , collectUpTo

44− , collectUpToGivenParent

71+ , collectUpToGivenParent

72+ , EventTriggerRef (..)

45− , EventFilterTriggerRef (..)

73+ , EventFilterTriggerRef (..)

46− , wrap

74+ , wrap

47− , makeElement

75+ , elementInternal

76+ , hydrateNode

77+ , HydrationDomSpace

78+ , GhcjsDomSpace

48− , GhcjsDomHandler (..)

79+ , GhcjsDomHandler (..)

49− , GhcjsDomHandler1 (..)

80+ , GhcjsDomHandler1 (..)

50− , GhcjsDomEvent (..)

81+ , GhcjsDomEvent (..)

51− , GhcjsDomSpace

52− , GhcjsEventFilter (..)

82+ , GhcjsEventFilter (..)

53− , Pair1 (..)

83+ , Pair1 (..)

54− , Maybe1 (..)

84+ , Maybe1 (..)

55− , GhcjsEventSpec (..)

85+ , GhcjsEventSpec (..)

56− , HasDocument (..)

86+ , HasDocument (..)

57− , ghcjsEventSpec_filters

87+ , ghcjsEventSpec_filters

58− , ghcjsEventSpec_handler

88+ , ghcjsEventSpec_handler

59− , GhcjsEventHandler (..)

89+ , GhcjsEventHandler (..)

60#ifndef USE_TEMPLATE_HASKELL

90#ifndef USE_TEMPLATE_HASKELL

61− , phantom2

91+ , phantom2

62#endif

92#endif

63− , drawChildUpdate

93+ , drawChildUpdate

64− , ChildReadyState (..)

94+ , ChildReadyState (..)

65− , ChildReadyStateInt (..)

66− , mkHasFocus

95+ , mkHasFocus

67− , insertBefore

96+ , insertBefore

68− , EventType

97+ , EventType

69− , defaultDomEventHandler

98+ , defaultDomEventHandler

70− , defaultDomWindowEventHandler

99+ , defaultDomWindowEventHandler

71− , withIsEvent

100+ , withIsEvent

72− , showEventName

101+ , showEventName

73− , elementOnEventName

102+ , elementOnEventName

74− , windowOnEventName

103+ , windowOnEventName

75− , wrapDomEvent

104+ , wrapDomEvent

76− , subscribeDomEvent

105+ , subscribeDomEvent

77− , wrapDomEventMaybe

106+ , wrapDomEventMaybe

78− , wrapDomEventsMaybe

107+ , wrapDomEventsMaybe

79− , getKeyEvent

108+ , getKeyEvent

80− , getMouseEventCoords

109+ , getMouseEventCoords

81− , getTouchEvent

110+ , getTouchEvent

82− , WindowConfig (..)

111+ , WindowConfig (..)

83− , Window (..)

112+ , Window (..)

84− , wrapWindow

113+ , wrapWindow

85− -- * Internal

114+ -- * Internal

86− , traverseDMapWithKeyWithAdjust'

115+ , traverseDMapWithKeyWithAdjust'

87− , hoistTraverseWithKeyWithAdjust

116+ , hoistTraverseWithKeyWithAdjust

88− , traverseIntMapWithKeyWithAdjust'

117+ , traverseIntMapWithKeyWithAdjust'

89− , hoistTraverseIntMapWithKeyWithAdjust

118+ , hoistTraverseIntMapWithKeyWithAdjust

90− ) where

119+ ) where

91−

92−import Foreign.JavaScript.TH

93−import Reflex.Adjustable.Class

94−import Reflex.Class as Reflex

95−import Reflex.Dom.Builder.Class

96−import Reflex.Dynamic

97−import Reflex.Host.Class

98−import qualified Reflex.Patch.DMap as PatchDMap

99−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

100−import Reflex.PerformEvent.Class

101−import Reflex.PostBuild.Class

102−import Reflex.TriggerEvent.Base hiding (askEvents)

103−import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)

104−import Reflex.TriggerEvent.Class

105

120

106import Control.Concurrent

121import Control.Concurrent

107−import Control.Lens hiding (element, ix)

122+import Control.Exception (bracketOnError)

123+import Control.Lens (Identity(..), imapM_, iforM_, (^.), makeLenses)

108import Control.Monad.Exception

124import Control.Monad.Exception

109import Control.Monad.Primitive

125import Control.Monad.Primitive

110import Control.Monad.Reader

126import Control.Monad.Reader

111import Control.Monad.Ref

127import Control.Monad.Ref

112−#ifndef USE_TEMPLATE_HASKELL

128+import Control.Monad.State.Strict (StateT, evalStateT, mapStateT, get, put)

113−import Data.Functor.Contravariant (phantom)

114−#endif

115import Data.Bitraversable

129import Data.Bitraversable

116import Data.Default

130import Data.Default

117import Data.Dependent.Map (DMap)

131import Data.Dependent.Map (DMap)

118−import qualified Data.Dependent.Map as DMap

119import Data.Dependent.Sum

132import Data.Dependent.Sum

133+import Data.FastMutableIntMap (PatchIntMap (..))

134+import Data.Foldable (for_)

120import Data.Functor.Compose

135import Data.Functor.Compose

121import Data.Functor.Constant

136import Data.Functor.Constant

122import Data.Functor.Misc

137import Data.Functor.Misc

123import Data.Functor.Product

138import Data.Functor.Product

124import Data.IORef

139import Data.IORef

125−import qualified Data.Map as Map

140+import Data.IntMap.Strict (IntMap)

126import Data.Maybe

141import Data.Maybe

127−import Data.Monoid hiding (Product)

142+import Data.Some (Some(..))

128−import Data.Some (Some)

129−import qualified Data.Some as Some

130import Data.Text (Text)

143import Data.Text (Text)

131−import qualified GHCJS.DOM as DOM

144+import Data.Typeable (Typeable)

145+import Foreign.JavaScript.Internal.Utils

146+import Foreign.JavaScript.TH

132import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

147import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

133−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

148+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)

149+import GHCJS.DOM.EventM (EventM, event, on)

150+import GHCJS.DOM.KeyboardEvent as KeyboardEvent

151+import GHCJS.DOM.MouseEvent

152+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)

153+import GHCJS.DOM.Types (liftJSM, askJSM, runJSM, JSM, MonadJSM, FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)

154+import GHCJS.DOM.UIEvent

155+import Language.Javascript.JSaddle (call, eval)

156+import Reflex.Adjustable.Class

157+import Reflex.Class as Reflex

158+import Reflex.Dom.Builder.Class

159+import Reflex.Dynamic

160+import Reflex.Host.Class

161+import Reflex.Patch.DMapWithMove (PatchDMapWithMove(..))

162+import Reflex.Patch.MapWithMove (PatchMapWithMove(..))

163+import Reflex.PerformEvent.Base (PerformEventT)

164+import Reflex.PerformEvent.Class

165+import Reflex.PostBuild.Base (PostBuildT)

166+import Reflex.PostBuild.Class

167+import Reflex.Requester.Base

168+import Reflex.Requester.Class

169+import Reflex.Spider (Spider, SpiderHost, Global)

170+import Reflex.TriggerEvent.Base hiding (askEvents)

171+import Reflex.TriggerEvent.Class

172+

173+import qualified Data.Dependent.Map as DMap

174+import qualified Data.FastMutableIntMap as FastMutableIntMap

175+import qualified Data.IntMap.Strict as IntMap

176+import qualified Data.Map as Map

177+import qualified Data.Text as T

178+import qualified GHCJS.DOM as DOM

179+import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events

180+import qualified GHCJS.DOM.DocumentOrShadowRoot as Document

134import qualified GHCJS.DOM.Element as Element

181import qualified GHCJS.DOM.Element as Element

135import qualified GHCJS.DOM.Event as Event

182import qualified GHCJS.DOM.Event as Event

136−import qualified GHCJS.DOM.GlobalEventHandlers as Events

137−import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events

138−import GHCJS.DOM.EventM (EventM, event, on)

139import qualified GHCJS.DOM.EventM as DOM

183import qualified GHCJS.DOM.EventM as DOM

140import qualified GHCJS.DOM.FileList as FileList

184import qualified GHCJS.DOM.FileList as FileList

185+import qualified GHCJS.DOM.GlobalEventHandlers as Events

141import qualified GHCJS.DOM.HTMLInputElement as Input

186import qualified GHCJS.DOM.HTMLInputElement as Input

142import qualified GHCJS.DOM.HTMLSelectElement as Select

187import qualified GHCJS.DOM.HTMLSelectElement as Select

143import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

188import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

144−import GHCJS.DOM.MouseEvent

189+import qualified GHCJS.DOM.Node as Node

190+import qualified GHCJS.DOM.Text as DOM

145import qualified GHCJS.DOM.Touch as Touch

191import qualified GHCJS.DOM.Touch as Touch

146import qualified GHCJS.DOM.TouchEvent as TouchEvent

192import qualified GHCJS.DOM.TouchEvent as TouchEvent

147import qualified GHCJS.DOM.TouchList as TouchList

193import qualified GHCJS.DOM.TouchList as TouchList

148−import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, setNodeValue, toNode)

149−import qualified GHCJS.DOM.Node as DOM (insertBefore_)

150−import GHCJS.DOM.Types

151− (liftJSM, askJSM, runJSM, JSM, MonadJSM,

152− FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,

153− ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo, ClipboardEvent)

154import qualified GHCJS.DOM.Types as DOM

194import qualified GHCJS.DOM.Types as DOM

155−import GHCJS.DOM.UIEvent

156−import GHCJS.DOM.KeyboardEvent as KeyboardEvent

157import qualified GHCJS.DOM.Window as Window

195import qualified GHCJS.DOM.Window as Window

158−import Language.Javascript.JSaddle (call, eval)

196+import qualified Reflex.Patch.DMap as PatchDMap

159−import Data.IntMap.Strict (IntMap)

197+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

160−import qualified Data.IntMap.Strict as IntMap

198+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

161−import Data.FastMutableIntMap (PatchIntMap (..))

199+import qualified Reflex.TriggerEvent.Base as TriggerEventT (askEvents)

162−import qualified Data.FastMutableIntMap as FastMutableIntMap

163

200

164−import Reflex.Requester.Base

201+#ifndef USE_TEMPLATE_HASKELL

165−import Reflex.Requester.Class

202+import Data.Functor.Contravariant (phantom)

166−import Foreign.JavaScript.Internal.Utils

203+#endif

167

204

168#ifndef ghcjs_HOST_OS

205#ifndef ghcjs_HOST_OS

169import GHCJS.DOM.Types (MonadJSM (..))

206import GHCJS.DOM.Types (MonadJSM (..))

170

207

171−instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where

208+instance MonadJSM m => MonadJSM (HydrationRunnerT t m) where

209+ {-# INLINABLE liftJSM' #-}

210+ liftJSM' = lift . liftJSM'

211+

212+instance MonadJSM m => MonadJSM (HydrationDomBuilderT s t m) where

213+ {-# INLINABLE liftJSM' #-}

214+ liftJSM' = lift . liftJSM'

215+

216+instance MonadJSM m => MonadJSM (DomRenderHookT t m) where

217+ {-# INLINABLE liftJSM' #-}

172− liftJSM' = ImmediateDomBuilderT . liftJSM'

218+ liftJSM' = lift . liftJSM'

173#endif

219#endif

174

220

175−data ImmediateDomBuilderEnv t

221+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv

176− = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document

222+ { _hydrationDomBuilderEnv_document :: {-# UNPACK #-} !Document

177− , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node

223+ -- ^ Reference to the document

224+ , _hydrationDomBuilderEnv_parent :: !(Either Node (IORef Node))

225+ -- ^ This is in an IORef because in the time up to hydration we can't actually know what the

226+ -- parent is - we populate this reference during the DOM traversal at hydration time

227+ , _hydrationDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word)

178− , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered

228+ -- ^ Number of children who still aren't fully rendered

229+ , _hydrationDomBuilderEnv_commitAction :: !(JSM ())

179− , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

230+ -- ^ Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

231+ , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode)

232+ -- ^ In hydration mode? Should be switched to `HydrationMode_Immediate` after hydration is finished

233+ , _hydrationDomBuilderEnv_switchover :: !(Event t ())

234+ , _hydrationDomBuilderEnv_delayed :: {-# UNPACK #-} !(IORef (HydrationRunnerT t m ()))

180− }

235+ }

181

236

182−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }

237+-- | A monad for DomBuilder which just gets the results of children and pushes

238+-- work into an action that is delayed until after postBuild (to match the

239+-- static builder). The action runs in 'HydrationRunnerT', which performs the

240+-- DOM takeover and sets up the events, after which point this monad will

241+-- continue in the vein of 'ImmediateDomBuilderT'.

242+newtype HydrationDomBuilderT s t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (DomRenderHookT t m) a }

183 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

243 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

184#if MIN_VERSION_base(4,9,1)

244#if MIN_VERSION_base(4,9,1)

185 , MonadAsyncException

245 , MonadAsyncException

186#endif

246#endif

187 )

247 )

188

248

189−instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where

249+instance PrimMonad m => PrimMonad (HydrationDomBuilderT s t m) where

190− type PrimState (ImmediateDomBuilderT x m) = PrimState m

250+ type PrimState (HydrationDomBuilderT s t m) = PrimState m

191 primitive = lift . primitive

251 primitive = lift . primitive

192

252

193−instance MonadTrans (ImmediateDomBuilderT t) where

253+instance MonadTrans (HydrationDomBuilderT s t) where

194− lift = ImmediateDomBuilderT . lift . lift . lift

254+ lift = HydrationDomBuilderT . lift . lift

255+

256+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT s t m) where

257+ withRenderHook hook = HydrationDomBuilderT . mapReaderT (withRenderHook hook) . unHydrationDomBuilderT

258+ requestDomAction = HydrationDomBuilderT . lift . requestDomAction

259+ requestDomAction_ = HydrationDomBuilderT . lift . requestDomAction_

260+

261+-- | The monad which performs the delayed actions to reuse prerendered nodes and set up events.

262+-- State contains reference to the previous node sibling, if any, and the reader contains reference to the parent node.

263+newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT (Maybe Node) (ReaderT Node (DomRenderHookT t m)) a }

264+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

265+#if MIN_VERSION_base(4,9,1)

266+ , MonadAsyncException

267+#endif

268+ )

195

269

270+{-# INLINABLE localRunner #-}

271+localRunner :: (MonadJSM m, Monad m) => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a

272+localRunner (HydrationRunnerT m) s parent = HydrationRunnerT . lift $ local (\_ -> parent) (evalStateT m s)

273+

274+{-# INLINABLE runHydrationRunnerT #-}

275+runHydrationRunnerT

276+ :: (MonadRef m, Ref m ~ IORef, Monad m, PerformEvent t m, MonadFix m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m))

277+ => HydrationRunnerT t m a -> Maybe Node -> Node -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

278+runHydrationRunnerT (HydrationRunnerT m) s parent = runDomRenderHookT (runReaderT (evalStateT m s) parent)

279+

280+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationRunnerT t m) where

281+ {-# INLINABLE newEventWithTrigger #-}

282+ newEventWithTrigger = lift . newEventWithTrigger

283+ {-# INLINABLE newFanEventWithTrigger #-}

284+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

285+

286+instance MonadTrans (HydrationRunnerT t) where

287+ {-# INLINABLE lift #-}

288+ lift = HydrationRunnerT . lift . lift . lift

289+

290+instance MonadSample t m => MonadSample t (HydrationRunnerT t m) where

291+ {-# INLINABLE sample #-}

292+ sample = lift . sample

293+

196−instance (Reflex t, MonadFix m) => DomRenderHook t (ImmediateDomBuilderT t m) where

294+instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationRunnerT t m) where

197− withRenderHook hook (ImmediateDomBuilderT a) = do

295+ withRenderHook hook = HydrationRunnerT . mapStateT (mapReaderT (withRenderHook hook)) . unHydrationRunnerT

198− e <- ImmediateDomBuilderT ask

296+ requestDomAction = HydrationRunnerT . lift . lift . requestDomAction

297+ requestDomAction_ = HydrationRunnerT . lift . lift . requestDomAction_

298+

299+-- | Add a hydration step which depends on some computation that should only be

300+-- done *before* the switchover to immediate mode - this is most likely some

301+-- form of 'hold' which we want to remove after hydration is done

302+{-# INLINABLE addHydrationStepWithSetup #-}

303+addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> HydrationRunnerT t m ()) -> HydrationDomBuilderT s t m ()

304+addHydrationStepWithSetup setup f = getHydrationMode >>= \case

305+ HydrationMode_Immediate -> pure ()

306+ HydrationMode_Hydrating -> do

307+ switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

308+ (s, _) <- lift $ runWithReplace setup $ return () <$ switchover -- 4% more memory than above

309+ addHydrationStep (f s)

310+

311+-- | Add a hydration step

312+{-# INLINABLE addHydrationStep #-}

313+addHydrationStep :: MonadIO m => HydrationRunnerT t m () -> HydrationDomBuilderT s t m ()

314+addHydrationStep m = do

315+ delayedRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_delayed

316+ liftIO $ modifyIORef' delayedRef (>> m)

317+

318+-- | Shared behavior for HydrationDomBuilderT and HydrationRunnerT

319+newtype DomRenderHookT t m a = DomRenderHookT { unDomRenderHookT :: RequesterT t JSM Identity (TriggerEventT t m) a }

320+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

321+#if MIN_VERSION_base(4,9,1)

322+ , MonadAsyncException

323+#endif

324+ )

325+

326+{-# INLINABLE runDomRenderHookT #-}

327+runDomRenderHookT

328+ :: (MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM m, MonadJSM (Performable m), MonadRef m, Ref m ~ IORef)

329+ => DomRenderHookT t m a

330+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

331+ -> m a

332+runDomRenderHookT (DomRenderHookT a) events = do

333+ flip runTriggerEventT events $ do

334+ rec (result, req) <- runRequesterT a rsp

335+ rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $

336+ traverseRequesterData (\r -> Identity <$> r) rm

337+ return result

338+ where

339+ runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do

340+ v <- synchronously x

341+ void . liftIO $ f v

342+

343+instance MonadTrans (DomRenderHookT t) where

344+ {-# INLINABLE lift #-}

345+ lift = DomRenderHookT . lift . lift

346+

347+instance (Reflex t, MonadFix m) => DomRenderHook t (DomRenderHookT t m) where

348+ withRenderHook hook (DomRenderHookT a) = do

199− ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do

349+ DomRenderHookT $ withRequesting $ \rsp -> do

200− (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp

350+ (x, req) <- lift $ runRequesterT a $ runIdentity <$> rsp

201 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)

351 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)

202− requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity

352+ requestDomAction = DomRenderHookT . requestingIdentity

203− requestDomAction_ = ImmediateDomBuilderT . lift . requesting_

353+ requestDomAction_ = DomRenderHookT . requesting_

204

354

205−{-# INLINABLE runImmediateDomBuilderT #-}

355+{-# INLINABLE runHydrationDomBuilderT #-}

206−runImmediateDomBuilderT

356+runHydrationDomBuilderT

207 :: ( MonadFix m

357 :: ( MonadFix m

208 , PerformEvent t m

358 , PerformEvent t m

209 , MonadReflexCreateTrigger t m

359 , MonadReflexCreateTrigger t m

@@ -212,57 +362,99 @@ runImmediateDomBuilderT

212 , MonadRef m

362 , MonadRef m

213 , Ref m ~ IORef

363 , Ref m ~ IORef

214 )

364 )

215− => ImmediateDomBuilderT t m a

365+ => HydrationDomBuilderT s t m a

216− -> ImmediateDomBuilderEnv t

366+ -> HydrationDomBuilderEnv t m

217 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

367 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

218 -> m a

368 -> m a

219−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =

369+runHydrationDomBuilderT (HydrationDomBuilderT a) env = runDomRenderHookT (runReaderT a env)

220− flip runTriggerEventT eventChan $ do

221− rec (x, req) <- runRequesterT (runReaderT a env) rsp

222− rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $

223− traverseRequesterData (\r -> Identity <$> r) rm

224− return x

225− where

226− runInAnimationFrame f x = void . DOM.inAnimationFrame' $ \_ -> do

227− v <- synchronously x

228− void . liftIO $ f v

229

370

230−instance Monad m => HasDocument (ImmediateDomBuilderT t m) where

371+instance (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, Monad m) => HasDocument (HydrationDomBuilderT s t m) where

231 {-# INLINABLE askDocument #-}

372 {-# INLINABLE askDocument #-}

232− askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document

373+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document

233

374

234{-# INLINABLE askParent #-}

375{-# INLINABLE askParent #-}

235−askParent :: Monad m => ImmediateDomBuilderT t m Node

376+askParent :: Monad m => HydrationRunnerT t m DOM.Node

236−askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent

377+askParent = HydrationRunnerT ask

378+

379+{-# INLINABLE getParent #-}

380+getParent :: MonadIO m => HydrationDomBuilderT s t m DOM.Node

381+getParent = either pure (liftIO . readIORef) =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)

237

382

238{-# INLINABLE askEvents #-}

383{-# INLINABLE askEvents #-}

239−askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

384+askEvents :: Monad m => HydrationDomBuilderT s t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

240−askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents

385+askEvents = HydrationDomBuilderT . lift . DomRenderHookT . lift $ TriggerEventT.askEvents

241

386

242−localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a

387+{-# INLINABLE localEnv #-}

243−localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT

388+localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT s t m a -> HydrationDomBuilderT s t m a

389+localEnv f = HydrationDomBuilderT . local (f $!) . unHydrationDomBuilderT

244

390

245{-# INLINABLE append #-}

391{-# INLINABLE append #-}

246−append :: MonadJSM m => DOM.Node -> ImmediateDomBuilderT t m ()

392+append :: MonadJSM m => DOM.Node -> HydrationDomBuilderT s t m ()

247append n = do

393append n = do

248− p <- askParent

394+ p <- getParent

249 liftJSM $ appendChild_ p n

395 liftJSM $ appendChild_ p n

250 return ()

396 return ()

251

397

252−{-# INLINABLE textNodeInternal #-}

398+{-# SPECIALIZE append

253−textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text

399+ :: DOM.Node

254−textNodeInternal !t = do

400+ -> HydrationDomBuilderT s Spider HydrationM ()

255− doc <- askDocument

401+ #-}

256− n <- liftJSM $ createTextNode doc t

402+

403+data HydrationMode

404+ = HydrationMode_Hydrating

405+ -- ^ The time from initial load to parity with static builder

406+ | HydrationMode_Immediate

407+ -- ^ After hydration

408+ deriving (Eq, Ord, Show)

409+

410+{-# INLINABLE getPreviousNode #-}

411+getPreviousNode :: Monad m => HydrationRunnerT t m (Maybe DOM.Node)

412+getPreviousNode = HydrationRunnerT get

413+

414+{-# INLINABLE setPreviousNode #-}

415+setPreviousNode :: Monad m => Maybe DOM.Node -> HydrationRunnerT t m ()

416+setPreviousNode = HydrationRunnerT . put

417+

418+{-# INLINABLE askUnreadyChildren #-}

419+askUnreadyChildren :: Monad m => HydrationDomBuilderT s t m (IORef Word)

420+askUnreadyChildren = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren

421+

422+{-# INLINABLE askCommitAction #-}

423+askCommitAction :: Monad m => HydrationDomBuilderT s t m (JSM ())

424+askCommitAction = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_commitAction

425+

426+{-# INLINABLE getHydrationMode #-}

427+getHydrationMode :: MonadIO m => HydrationDomBuilderT s t m HydrationMode

428+getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_hydrationMode)

429+

430+{-# INLINE makeNodeInternal #-}

431+makeNodeInternal

432+ :: forall node s t m. (MonadJSM m, IsNode node, Typeable node)

433+ => HydrationDomBuilderT s t m node -> HydrationDomBuilderT s t m node

434+makeNodeInternal mkNode = do

435+ n <- mkNode

257 append $ toNode n

436 append $ toNode n

258 return n

437 return n

259

438

260−{-# INLINABLE commentNodeInternal #-}

439+{-# INLINE hydrateNode #-}

261−commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Comment

440+-- | This function expects the existing DOM at the current hydration node to be

262−commentNodeInternal !t = do

441+-- correct. It skips any nodes that are the wrong type, or that fail the

263− doc <- askDocument

442+-- @check@. The previous node reference is also updated.

264− n <- liftJSM $ createComment doc t

443+hydrateNode

265− append $ toNode n

444+ :: (MonadJSM m, IsNode node, Typeable node)

445+ => (node -> HydrationRunnerT t m Bool) -> (DOM.JSVal -> node) -> HydrationRunnerT t m node

446+hydrateNode check constructor = do

447+ parent <- askParent

448+ lastHydrationNode <- getPreviousNode

449+ let go mLastNode = do

450+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

451+ DOM.castTo constructor node >>= \case

452+ Nothing -> go (Just node)

453+ Just tn -> check tn >>= \case

454+ True -> return tn

455+ False -> go (Just node)

456+ n <- go lastHydrationNode

457+ setPreviousNode $ Just $ toNode n

266 return n

458 return n

267

459

268-- | s and e must both be children of the same node and s must precede e;

460-- | s and e must both be children of the same node and s must precede e;

@@ -301,7 +493,7 @@ extractUpTo df s e = liftJSM $ do

301 void $ call f f (df, s, e)

493 void $ call f f (df, s, e)

302#endif

494#endif

303

495

304−type SupportsImmediateDomBuilder 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)

496+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))

305

497

306{-# INLINABLE collectUpTo #-}

498{-# INLINABLE collectUpTo #-}

307collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment

499collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment

@@ -319,10 +511,15 @@ collectUpToGivenParent currentParent s e = do

319

511

320newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

512newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

321

513

322−{-# INLINABLE wrap #-}

514+-- | This 'wrap' is only partial: it doesn't create the 'EventSelector' itself

515+{-# INLINE wrap #-}

516+wrap

323−wrap :: forall m er t. (Reflex t, MonadFix m, MonadJSM m, MonadReflexCreateTrigger t m) => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)

517+ :: forall s m er t. (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m, EventSpec s ~ GhcjsEventSpec)

518+ => Chan [DSum (EventTriggerRef t) TriggerInvocation]

519+ -> DOM.Element

520+ -> RawElementConfig er t s

521+ -> m (DMap EventName (EventFilterTriggerRef t er))

324−wrap e cfg = do

522+wrap events e cfg = do

325− events <- askEvents

326 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

523 forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

327 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

524 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

328 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

525 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

@@ -339,46 +536,74 @@ wrap e cfg = do

339 mv <- liftJSM k --TODO: Only do this when the event is subscribed

536 mv <- liftJSM k --TODO: Only do this when the event is subscribed

340 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]

537 liftIO $ forM_ mv $ \v -> writeChan events [EventTriggerRef triggerRef :=> TriggerInvocation v (return ())]

341 return $ en :=> EventFilterTriggerRef triggerRef

538 return $ en :=> EventFilterTriggerRef triggerRef

342− es <- do

539+ return eventTriggerRefs

343− let h :: GhcjsEventHandler er

540+

344− !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

541+{-# SPECIALIZE wrap

345− ctx <- askJSM

542+ :: Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

346− newFanEventWithTrigger $ \(WrapArg en) t ->

543+ -> DOM.Element

544+ -> RawElementConfig er Spider HydrationDomSpace

545+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (DMap EventName (EventFilterTriggerRef Spider er))

546+ #-}

547+

548+{-# SPECIALIZE wrap

549+ :: Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

550+ -> DOM.Element

551+ -> RawElementConfig er Spider GhcjsDomSpace

552+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (DMap EventName (EventFilterTriggerRef Spider er))

553+ #-}

554+

555+{-# INLINE triggerBody #-}

556+triggerBody

557+ :: forall s er t x. EventSpec s ~ GhcjsEventSpec

558+ => DOM.JSContextRef

559+ -> RawElementConfig er t s

560+ -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

561+ -> DMap EventName (EventFilterTriggerRef t er)

562+ -> DOM.Element

563+ -> WrapArg er EventName x

564+ -> EventTrigger t x

565+ -> IO (IO ())

347− case DMap.lookup en eventTriggerRefs of

566+triggerBody ctx cfg events eventTriggerRefs e (WrapArg en) t = case DMap.lookup en eventTriggerRefs of

348− Just (EventFilterTriggerRef r) -> do

567+ Just (EventFilterTriggerRef r) -> do

349− writeIORef r $ Just t

568+ writeIORef r $ Just t

350− return $ do

569+ return $ do

351− writeIORef r Nothing

570+ writeIORef r Nothing

352− Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

571+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

353− evt <- DOM.event

572+ evt <- DOM.event

354− mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)

573+ mv <- lift $ unGhcjsEventHandler handler (en, GhcjsDomEvent evt)

355− case mv of

574+ case mv of

356− Nothing -> return ()

575+ Nothing -> return ()

357− Just v -> liftIO $ do

576+ Just v -> liftIO $ do

358− --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

577+ --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

359− ref <- newIORef $ Just t

578+ ref <- newIORef $ Just t

360− writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

579+ writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

361− return $ Element

580+ where

362− { _element_events = es

581+ -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't

363− , _element_raw = e

582+ -- retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up

364− }

583+ handler :: GhcjsEventHandler er

365−

584+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg

366−{-# INLINABLE makeElement #-}

585+

367−makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)

586+{-# SPECIALIZE triggerBody

368−makeElement elementTag cfg child = do

587+ :: DOM.JSContextRef

369− doc <- askDocument

588+ -> RawElementConfig er Spider HydrationDomSpace

370− e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

589+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

371− Nothing -> createElement doc elementTag

590+ -> DMap EventName (EventFilterTriggerRef Spider er)

372− Just ens -> createElementNS doc (Just ens) elementTag

591+ -> DOM.Element

373− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

592+ -> WrapArg er EventName x

374− Nothing -> lift $ setAttribute e n v

593+ -> EventTrigger Spider x

375− Just ans -> lift $ setAttributeNS e (Just ans) n v

594+ -> IO (IO ())

376− result <- flip localEnv child $ \env -> env

595+ #-}

377− { _immediateDomBuilderEnv_parent = toNode e

596+

378− }

597+{-# SPECIALIZE triggerBody

379− append $ toNode e

598+ :: DOM.JSContextRef

380− wrapped <- wrap e $ extractRawElementConfig cfg

599+ -> RawElementConfig er Spider GhcjsDomSpace

381− return ((wrapped, result), e)

600+ -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

601+ -> DMap EventName (EventFilterTriggerRef Spider er)

602+ -> DOM.Element

603+ -> WrapArg er EventName x

604+ -> EventTrigger Spider x

605+ -> IO (IO ())

606+ #-}

382

607

383newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }

608newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }

384

609

@@ -446,142 +671,677 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where

446 runReaderT (defaultDomEventHandler e en) evt

671 runReaderT (defaultDomEventHandler e en) evt

447 }

672 }

448

673

449−instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where

674+{-# INLINE elementImmediate #-}

675+elementImmediate

676+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec

677+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m )

678+ => Text

679+ -> ElementConfig er t s

680+ -> HydrationDomBuilderT s t m a

681+ -> HydrationDomBuilderT s t m (Element er GhcjsDomSpace t, a)

682+elementImmediate elementTag cfg child = do

683+ doc <- askDocument

684+ ctx <- askJSM

685+ events <- askEvents

686+ e <- makeNodeInternal . liftJSM $ do

687+ e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

688+ Nothing -> createElement doc elementTag

689+ Just ens -> createElementNS doc (Just ens) elementTag

690+ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

691+ Nothing -> setAttribute e n v

692+ Just ans -> setAttributeNS e (Just ans) n v

693+ pure e

694+ -- Run the child builder with updated parent and previous sibling references

695+ result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = Left $ toNode e }) child

696+ let rawCfg = extractRawElementConfig cfg

697+ eventTriggerRefs <- wrap events e rawCfg

698+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e

699+ return (Element es e, result)

700+

701+{-# SPECIALIZE elementImmediate

702+ :: Text

703+ -> ElementConfig er Spider HydrationDomSpace

704+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM a

705+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (Element er GhcjsDomSpace Spider, a)

706+ #-}

707+

708+{-# SPECIALIZE elementImmediate

709+ :: Text

710+ -> ElementConfig er Spider GhcjsDomSpace

711+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM a

712+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (Element er GhcjsDomSpace Spider, a)

713+ #-}

714+

715+-- For specialisation

716+

717+-- | The Reflex timeline for interacting with the DOM

718+type DomTimeline =

719+#ifdef PROFILE_REFLEX

720+ ProfiledTimeline

721+#endif

722+ Spider

723+

724+-- | The ReflexHost the DOM lives in

725+type DomHost =

726+#ifdef PROFILE_REFLEX

727+ ProfiledM

728+#endif

729+ (SpiderHost Global)

730+

731+type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))

732+type HydrationM = DomCoreWidget ()

733+

734+{-# INLINE elementInternal #-}

735+elementInternal

736+ :: (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)

737+ => Text

738+ -> ElementConfig er t HydrationDomSpace

739+ -> HydrationDomBuilderT HydrationDomSpace t m a

740+ -> HydrationDomBuilderT HydrationDomSpace t m (Element er HydrationDomSpace t, a)

741+elementInternal elementTag cfg child = getHydrationMode >>= \case

742+ HydrationMode_Immediate -> do

743+ (Element es _, result) <- elementImmediate elementTag cfg child

744+ return (Element es (), result)

745+ HydrationMode_Hydrating -> fst <$> hydrateElement elementTag cfg child

746+

747+{-# SPECIALIZE elementInternal

748+ :: Text

749+ -> ElementConfig er Spider HydrationDomSpace

750+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM a

751+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (Element er HydrationDomSpace Spider, a)

752+ #-}

753+

754+{-# INLINE hydrateElement #-}

755+hydrateElement

756+ :: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)

757+ => Text

758+ -> ElementConfig er t HydrationDomSpace

759+ -> HydrationDomBuilderT HydrationDomSpace t m a

760+ -> HydrationDomBuilderT HydrationDomSpace t m ((Element er HydrationDomSpace t, a), IORef DOM.Element)

761+hydrateElement _elementTag cfg child = do

762+ ctx <- askJSM

763+ events <- askEvents

764+ -- Schedule everything for after postBuild, except for getting the result itself

765+ parent <- liftIO $ newIORef $ error "Parent not yet initialized"

766+ e' <- liftIO $ newIORef $ error "hydrateElement: Element not yet initialized"

767+ env <- HydrationDomBuilderT ask

768+ childDelayedRef <- liftIO $ newIORef $ pure ()

769+ let env' = env

770+ { _hydrationDomBuilderEnv_parent = Right parent

771+ , _hydrationDomBuilderEnv_delayed = childDelayedRef

772+ }

773+ result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'

774+ wrapResult <- liftIO newEmptyMVar

775+ let ssrAttr = "data-ssr" :: DOM.JSString

776+ hasSSRAttribute :: DOM.Element -> HydrationRunnerT t m Bool

777+ hasSSRAttribute e = case cfg ^. namespace of

778+ Nothing -> hasAttribute e ssrAttr <* removeAttribute e ssrAttr

779+ Just ns -> hasAttributeNS e (Just ns) ssrAttr <* removeAttributeNS e (Just ns) ssrAttr

780+ childDom <- liftIO $ readIORef childDelayedRef

781+ let rawCfg = extractRawElementConfig cfg

782+ addHydrationStep $ do

783+ e <- hydrateNode hasSSRAttribute DOM.Element

784+ -- Update the parent node used by the children

785+ liftIO $ writeIORef parent $ toNode e

786+ liftIO $ writeIORef e' e

787+ -- Setup events, store the result so we can wait on it later

788+ refs <- wrap events e rawCfg

789+ liftIO $ putMVar wrapResult (e, refs)

790+ localRunner childDom Nothing $ toNode e

791+ -- We need the EventSelector to switch to the real event handler after activation

792+ es <- newFanEventWithTrigger $ \(WrapArg en) t -> do

793+ cleanup <- newEmptyMVar

794+ threadId <- forkIO $ do

795+ -- Wait on the data we need from the delayed action

796+ (e, eventTriggerRefs) <- readMVar wrapResult

797+ bracketOnError

798+ -- Run the setup, acquiring the cleanup action

799+ (triggerBody ctx rawCfg events eventTriggerRefs e (WrapArg en) t)

800+ -- Run the cleanup, if we have it - but only when an exception is

801+ -- raised (we might get killed between acquiring the cleanup action

802+ -- from 'triggerBody' and putting it in the MVar)

803+ id

804+ -- Try to put this action into the cleanup MVar

805+ (putMVar cleanup)

806+ pure $ do

807+ tryReadMVar cleanup >>= \case

808+ Nothing -> killThread threadId

809+ Just c -> c

810+ return ((Element es (), result), e')

811+

812+{-# SPECIALIZE hydrateElement

813+ :: Text

814+ -> ElementConfig er Spider HydrationDomSpace

815+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM a

816+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM ((Element er HydrationDomSpace Spider, a), IORef DOM.Element)

817+ #-}

818+

819+{-# INLINE inputElementImmediate #-}

820+inputElementImmediate

821+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec

822+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m

823+ , MonadRef m, Ref m ~ IORef )

824+ => InputElementConfig er t s -> HydrationDomBuilderT s t m (InputElement er GhcjsDomSpace t)

825+inputElementImmediate cfg = do

826+ (e@(Element eventSelector domElement), ()) <- elementImmediate "input" (_inputElementConfig_elementConfig cfg) $ return ()

827+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

828+ Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue

829+ v0 <- Input.getValue domInputElement

830+ let getMyValue = Input.getValue domInputElement

831+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)

832+ valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

833+ Nothing -> return never

834+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

835+ Input.setValue domInputElement v'

836+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

837+ v <- holdDyn v0 $ leftmost

838+ [ valueChangedBySetValue

839+ , valueChangedByUI

840+ ]

841+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

842+ checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do

843+ Input.getChecked domInputElement

844+ checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of

845+ Nothing -> return never

846+ Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do

847+ oldChecked <- Input.getChecked domInputElement

848+ Input.setChecked domInputElement newChecked

849+ return $ if newChecked /= oldChecked

850+ then Just newChecked

851+ else Nothing

852+ c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

853+ [ fmapMaybe id checkedChangedBySetChecked

854+ , checkedChangedByUI

855+ ]

856+ hasFocus <- mkHasFocus e

857+ files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do

858+ mfiles <- Input.getFiles domInputElement

859+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

860+ maybe (return []) getMyFiles mfiles

861+ checked <- holdUniqDyn c

862+ return $ InputElement

863+ { _inputElement_value = v

864+ , _inputElement_checked = checked

865+ , _inputElement_checkedChange = checkedChangedByUI

866+ , _inputElement_input = valueChangedByUI

867+ , _inputElement_hasFocus = hasFocus

868+ , _inputElement_element = e

869+ , _inputElement_raw = domInputElement

870+ , _inputElement_files = files

871+ }

872+

873+{-# INLINE inputElementInternal #-}

874+inputElementInternal

875+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m

876+ , MonadRef m, Ref m ~ IORef )

877+ => InputElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (InputElement er HydrationDomSpace t)

878+inputElementInternal cfg = getHydrationMode >>= \case

879+ HydrationMode_Immediate -> ffor (inputElementImmediate cfg) $ \result -> result

880+ { _inputElement_element = Element (_element_events $ _inputElement_element result) ()

881+ , _inputElement_raw = ()

882+ }

883+ HydrationMode_Hydrating -> do

884+ ((e, _), domElementRef) <- hydrateElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

885+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

886+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

887+ (focusChange, triggerFocusChange) <- newTriggerEvent

888+ (checkedChangedByUI, triggerCheckedChangedByUI) <- newTriggerEvent

889+ (checkedChangedBySetChecked, triggerCheckedChangedBySetChecked) <- newTriggerEvent

890+ (fileChange, triggerFileChange) <- newTriggerEvent

891+ doc <- askDocument

892+ -- Expected initial value from config

893+ let v0 = _inputElementConfig_initialValue cfg

894+ addHydrationStep $ do

895+ domElement <- liftIO $ readIORef domElementRef

896+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

897+ getValue = Input.getValue domInputElement

898+ -- The browser might have messed with the value, or the user could have

899+ -- altered it before activation, so we set it if it isn't what we expect

900+ liftJSM getValue >>= \v0' -> do

901+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

902+ -- Watch for user interaction and trigger event accordingly

903+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

904+ for_ (_inputElementConfig_setValue cfg) $ \eSetValue ->

905+ requestDomAction_ $ ffor eSetValue $ \v' -> do

906+ Input.setValue domInputElement v'

907+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

908+ liftIO $ triggerChangeBySetValue v

909+ let focusChange' = leftmost

910+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

911+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)

912+ ]

913+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

914+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

915+ Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

916+ _ <- liftJSM $ domInputElement `on` Events.click $ do

917+ liftIO . triggerCheckedChangedByUI =<< Input.getChecked domInputElement

918+ for_ (_inputElementConfig_setChecked cfg) $ \eNewchecked ->

919+ requestDomAction $ ffor eNewchecked $ \newChecked -> do

920+ oldChecked <- Input.getChecked domInputElement

921+ Input.setChecked domInputElement newChecked

922+ when (newChecked /= oldChecked) $ liftIO $ triggerCheckedChangedBySetChecked newChecked

923+ _ <- liftJSM $ domInputElement `on` Events.change $ do

924+ mfiles <- Input.getFiles domInputElement

925+ let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

926+ liftIO . triggerFileChange =<< maybe (return []) getMyFiles mfiles

927+ return ()

928+ checked' <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

929+ [ checkedChangedBySetChecked

930+ , checkedChangedByUI

931+ ]

932+ checked <- holdUniqDyn checked'

933+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

934+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange

935+ v <- holdDyn v0 $ leftmost

936+ [ valueChangedBySetValue

937+ , valueChangedByUI

938+ ]

939+ files <- holdDyn mempty fileChange

940+ return $ InputElement

941+ { _inputElement_value = v

942+ , _inputElement_checked = checked

943+ , _inputElement_checkedChange = checkedChangedByUI

944+ , _inputElement_input = valueChangedByUI

945+ , _inputElement_hasFocus = hasFocus

946+ , _inputElement_element = e

947+ , _inputElement_raw = ()

948+ , _inputElement_files = files

949+ }

950+

951+{-# INLINE textAreaElementImmediate #-}

952+textAreaElementImmediate

953+ :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, EventSpec s ~ GhcjsEventSpec

954+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m

955+ , MonadRef m, Ref m ~ IORef )

956+ => TextAreaElementConfig er t s -> HydrationDomBuilderT s t m (TextAreaElement er GhcjsDomSpace t)

957+textAreaElementImmediate cfg = do

958+ (e@(Element eventSelector domElement), _) <- elementImmediate "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

959+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

960+ TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue

961+ v0 <- TextArea.getValue domTextAreaElement

962+ let getMyValue = TextArea.getValue domTextAreaElement

963+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Input)

964+ valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

965+ Nothing -> return never

966+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

967+ TextArea.setValue domTextAreaElement v'

968+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

969+ v <- holdDyn v0 $ leftmost

970+ [ valueChangedBySetValue

971+ , valueChangedByUI

972+ ]

973+ hasFocus <- mkHasFocus e

974+ return $ TextAreaElement

975+ { _textAreaElement_value = v

976+ , _textAreaElement_input = valueChangedByUI

977+ , _textAreaElement_hasFocus = hasFocus

978+ , _textAreaElement_element = e

979+ , _textAreaElement_raw = domTextAreaElement

980+ }

981+

982+{-# INLINE textAreaElementInternal #-}

983+textAreaElementInternal

984+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m

985+ , MonadRef m, Ref m ~ IORef )

986+ => TextAreaElementConfig er t HydrationDomSpace -> HydrationDomBuilderT HydrationDomSpace t m (TextAreaElement er HydrationDomSpace t)

987+textAreaElementInternal cfg = getHydrationMode >>= \case

988+ HydrationMode_Immediate -> ffor (textAreaElementImmediate cfg) $ \result -> result

989+ { _textAreaElement_element = Element (_element_events $ _textAreaElement_element result) ()

990+ , _textAreaElement_raw = ()

991+ }

992+ HydrationMode_Hydrating -> do

993+ ((e, _), domElementRef) <- hydrateElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

994+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

995+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

996+ (focusChange, triggerFocusChange) <- newTriggerEvent

997+ doc <- askDocument

998+ -- Expected initial value from config

999+ let v0 = _textAreaElementConfig_initialValue cfg

1000+ addHydrationStep $ do

1001+ domElement <- liftIO $ readIORef domElementRef

1002+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

1003+ getValue = TextArea.getValue domTextAreaElement

1004+ -- The browser might have messed with the value, or the user could have

1005+ -- altered it before activation, so we set it if it isn't what we expect

1006+ liftJSM getValue >>= \v0' -> do

1007+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

1008+ -- Watch for user interaction and trigger event accordingly

1009+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Input)

1010+ for_ (_textAreaElementConfig_setValue cfg) $ \eSetValue ->

1011+ requestDomAction_ $ ffor eSetValue $ \v' -> do

1012+ TextArea.setValue domTextAreaElement v'

1013+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

1014+ liftIO $ triggerChangeBySetValue v

1015+ let focusChange' = leftmost

1016+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

1017+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)

1018+ ]

1019+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

1020+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

1021+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

1022+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange

1023+ v <- holdDyn v0 $ leftmost

1024+ [ valueChangedBySetValue

1025+ , valueChangedByUI

1026+ ]

1027+ return $ TextAreaElement

1028+ { _textAreaElement_value = v

1029+ , _textAreaElement_input = valueChangedByUI

1030+ , _textAreaElement_hasFocus = hasFocus

1031+ , _textAreaElement_element = e

1032+ , _textAreaElement_raw = ()

1033+ }

1034+

1035+{-# INLINE selectElementImmediate #-}

1036+selectElementImmediate

1037+ :: ( EventSpec s ~ GhcjsEventSpec, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document

1038+ , MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m )

1039+ => SelectElementConfig er t s

1040+ -> HydrationDomBuilderT s t m a

1041+ -> HydrationDomBuilderT s t m (SelectElement er GhcjsDomSpace t, a)

1042+selectElementImmediate cfg child = do

1043+ (e@(Element eventSelector domElement), result) <- elementImmediate "select" (cfg ^. selectElementConfig_elementConfig) child

1044+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

1045+ Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue

1046+ v0 <- Select.getValue domSelectElement

1047+ let getMyValue = Select.getValue domSelectElement

1048+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select eventSelector (WrapArg Change)

1049+ valueChangedBySetValue <- case _selectElementConfig_setValue cfg of

1050+ Nothing -> return never

1051+ Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

1052+ Select.setValue domSelectElement v'

1053+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

1054+ v <- holdDyn v0 $ leftmost

1055+ [ valueChangedBySetValue

1056+ , valueChangedByUI

1057+ ]

1058+ hasFocus <- mkHasFocus e

1059+ let wrapped = SelectElement

1060+ { _selectElement_value = v

1061+ , _selectElement_change = valueChangedByUI

1062+ , _selectElement_hasFocus = hasFocus

1063+ , _selectElement_element = e

1064+ , _selectElement_raw = domSelectElement

1065+ }

1066+ return (wrapped, result)

1067+

1068+{-# INLINE selectElementInternal #-}

1069+selectElementInternal

1070+ :: ( MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m, MonadHold t m

1071+ , MonadRef m, Ref m ~ IORef )

1072+ => SelectElementConfig er t HydrationDomSpace

1073+ -> HydrationDomBuilderT HydrationDomSpace t m a

1074+ -> HydrationDomBuilderT HydrationDomSpace t m (SelectElement er HydrationDomSpace t, a)

1075+selectElementInternal cfg child = getHydrationMode >>= \case

1076+ HydrationMode_Immediate -> ffor (selectElementImmediate cfg child) $ \(e, result) -> (e

1077+ { _selectElement_element = Element (_element_events $ _selectElement_element e) ()

1078+ , _selectElement_raw = ()

1079+ }, result)

1080+ HydrationMode_Hydrating -> do

1081+ ((e, result), domElementRef) <- hydrateElement "select" (cfg ^. selectElementConfig_elementConfig) child

1082+ (valueChangedByUI, triggerChangeByUI) <- newTriggerEvent

1083+ (valueChangedBySetValue, triggerChangeBySetValue) <- newTriggerEvent

1084+ (focusChange, triggerFocusChange) <- newTriggerEvent

1085+ doc <- askDocument

1086+ -- Expected initial value from config

1087+ let v0 = _selectElementConfig_initialValue cfg

1088+ addHydrationStep $ do

1089+ domElement <- liftIO $ readIORef domElementRef

1090+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

1091+ getValue = Select.getValue domSelectElement

1092+ -- The browser might have messed with the value, or the user could have

1093+ -- altered it before activation, so we set it if it isn't what we expect

1094+ liftJSM getValue >>= \v0' -> do

1095+ when (v0' /= v0) $ liftIO $ triggerChangeByUI v0'

1096+ -- Watch for user interaction and trigger event accordingly

1097+ requestDomAction_ $ (liftJSM getValue >>= liftIO . triggerChangeByUI) <$ Reflex.select (_element_events e) (WrapArg Change)

1098+ for_ (_selectElementConfig_setValue cfg) $ \eSetValue ->

1099+ requestDomAction_ $ ffor eSetValue $ \v' -> do

1100+ Select.setValue domSelectElement v'

1101+ v <- getValue -- We get the value after setting it in case the browser has mucked with it somehow

1102+ liftIO $ triggerChangeBySetValue v

1103+ let focusChange' = leftmost

1104+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

1105+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)

1106+ ]

1107+ liftIO . triggerFocusChange =<< Node.isSameNode (toNode domElement) . fmap toNode =<< Document.getActiveElement doc

1108+ requestDomAction_ $ liftIO . triggerFocusChange <$> focusChange'

1109+ let initialFocus = False -- Assume it isn't focused, but we update the actual focus state at switchover

1110+ hasFocus <- holdUniqDyn =<< holdDyn initialFocus focusChange

1111+ v <- holdDyn v0 $ leftmost

1112+ [ valueChangedBySetValue

1113+ , valueChangedByUI

1114+ ]

1115+ return $ (,result) $ SelectElement

1116+ { _selectElement_value = v

1117+ , _selectElement_change = valueChangedByUI

1118+ , _selectElement_hasFocus = hasFocus

1119+ , _selectElement_element = e

1120+ , _selectElement_raw = ()

1121+ }

1122+

1123+{-# INLINE textNodeImmediate #-}

1124+textNodeImmediate

1125+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)

1126+ => TextNodeConfig t -> HydrationDomBuilderT s t m DOM.Text

1127+textNodeImmediate (TextNodeConfig !t mSetContents) = do

1128+ n <- makeNodeInternal (askDocument >>= \doc -> createTextNode doc t)

1129+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1130+ pure n

1131+

1132+{-# SPECIALIZE textNodeImmediate

1133+ :: TextNodeConfig DomTimeline

1134+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM DOM.Text

1135+ #-}

1136+

1137+{-# SPECIALIZE textNodeImmediate

1138+ :: TextNodeConfig DomTimeline

1139+ -> HydrationDomBuilderT GhcjsDomSpace DomTimeline HydrationM DOM.Text

1140+ #-}

1141+

1142+{-# INLINE textNodeInternal #-}

1143+textNodeInternal

1144+ :: (Adjustable t m, MonadHold t m, MonadJSM m, MonadFix m, Reflex t)

1145+ => TextNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (TextNode HydrationDomSpace t)

1146+textNodeInternal tc@(TextNodeConfig !t mSetContents) = do

1147+ getHydrationMode >>= \case

1148+ HydrationMode_Immediate -> void $ textNodeImmediate tc

1149+ HydrationMode_Hydrating -> addHydrationStepWithSetup (maybe (pure $ pure t) (hold t) mSetContents) $ \currentText -> do

1150+ n <- hydrateTextNode =<< sample currentText

1151+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1152+ pure $ TextNode ()

1153+

1154+{-# SPECIALIZE textNodeInternal

1155+ :: TextNodeConfig DomTimeline

1156+ -> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (TextNode HydrationDomSpace DomTimeline)

1157+ #-}

1158+

1159+-- | The static builder mashes adjacent text nodes into one node: we check the

1160+-- text content of each node we come to, comparing it to the content we

1161+-- expect. We also have a special case for empty text nodes - we always create

1162+-- the and add them after the previous node reference.

1163+{-# INLINE hydrateTextNode #-}

1164+hydrateTextNode :: MonadJSM m => Text -> HydrationRunnerT t m DOM.Text

1165+hydrateTextNode t@"" = do

1166+ doc <- Node.getOwnerDocumentUnchecked =<< askParent

1167+ tn <- createTextNode doc t

1168+ insertAfterPreviousNode tn

1169+ pure tn

1170+hydrateTextNode t = do

1171+ n <- join $ go <$> askParent <*> getPreviousNode

1172+ setPreviousNode $ Just $ toNode n

1173+ return n

1174+ where

1175+ go parent mLastNode = do

1176+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

1177+ DOM.castTo DOM.Text node >>= \case

1178+ Nothing -> go parent $ Just node

1179+ Just originalNode -> do

1180+ originalText <- Node.getTextContentUnchecked originalNode

1181+ case T.stripPrefix t originalText of

1182+ Just "" -> return originalNode

1183+ Just _ -> do

1184+ -- If we have the right prefix, we split the text node into a node containing the

1185+ -- required text and a subsequent sibling node containing the rest of the text.

1186+ DOM.splitText_ originalNode $ fromIntegral $ T.length t

1187+ return originalNode

1188+ Nothing -> go parent $ Just $ toNode originalNode

1189+

1190+{-# INLINE commentNodeImmediate #-}

1191+commentNodeImmediate

1192+ :: (RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document, MonadJSM m, Reflex t, MonadFix m)

1193+ => CommentNodeConfig t -> HydrationDomBuilderT s t m DOM.Comment

1194+commentNodeImmediate (CommentNodeConfig !t mSetContents) = do

1195+ n <- makeNodeInternal (askDocument >>= \doc -> createComment doc t)

1196+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1197+ pure n

1198+

1199+{-# INLINE commentNodeInternal #-}

1200+commentNodeInternal

1201+ :: (Ref m ~ IORef, MonadRef m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadJSM m, MonadFix m, Reflex t, Adjustable t m)

1202+ => CommentNodeConfig t -> HydrationDomBuilderT HydrationDomSpace t m (CommentNode HydrationDomSpace t)

1203+commentNodeInternal tc@(CommentNodeConfig _t mSetContents) = do

1204+ getHydrationMode >>= \case

1205+ HydrationMode_Immediate -> void $ commentNodeInternal tc

1206+ HydrationMode_Hydrating -> addHydrationStep $ do

1207+ n <- hydrateNode (const $ pure True) DOM.Comment

1208+ mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1209+ pure $ CommentNode ()

1210+

1211+

1212+-- | We leave markers in the static builder as comments, and rip these comments

1213+-- out at hydration time, replacing them with empty text nodes.

1214+{-# INLINABLE skipToAndReplaceComment #-}

1215+skipToAndReplaceComment

1216+ :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)

1217+ => Text

1218+ -> IORef Text

1219+ -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)

1220+skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case

1221+ HydrationMode_Immediate -> do

1222+ -- If we're in immediate mode, we don't try to replace an existing comment,

1223+ -- and just return a dummy key

1224+ t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

1225+ append $ toNode t

1226+ textNodeRef <- liftIO $ newIORef t

1227+ keyRef <- liftIO $ newIORef ""

1228+ pure (pure (), textNodeRef, keyRef)

1229+ HydrationMode_Hydrating -> do

1230+ doc <- askDocument

1231+ textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"

1232+ keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"

1233+ let go key0 mLastNode = do

1234+ parent <- askParent

1235+ node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode

1236+ DOM.castTo DOM.Comment node >>= \case

1237+ Just comment -> do

1238+ commentText <- Node.getTextContentUnchecked comment

1239+ case T.stripPrefix (prefix <> key0) commentText of

1240+ Just key -> do

1241+ -- Replace the comment with an (invisible) text node

1242+ tn <- createTextNode doc ("" :: Text)

1243+ Node.replaceChild_ parent tn comment

1244+ pure (tn, key)

1245+ Nothing -> do

1246+ go key0 (Just node)

1247+ Nothing -> do

1248+ go key0 (Just node)

1249+ switchComment = do

1250+ key0 <- liftIO $ readIORef key0Ref

1251+ (tn, key) <- go key0 =<< getPreviousNode

1252+ setPreviousNode $ Just $ toNode tn

1253+ liftIO $ do

1254+ writeIORef textNodeRef tn

1255+ writeIORef keyRef key

1256+ pure (switchComment, textNodeRef, keyRef)

1257+

1258+{-# INLINABLE skipToReplaceStart #-}

1259+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)

1260+skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")

1261+

1262+{-# INLINABLE skipToReplaceEnd #-}

1263+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)

1264+skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key

1265+

1266+instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where

450 notReadyUntil e = do

1267 notReadyUntil e = do

451 eOnce <- headE e

1268 eOnce <- headE e

452− env <- ImmediateDomBuilderT ask

1269+ unreadyChildren <- askUnreadyChildren

453− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

1270+ commitAction <- askCommitAction

454 liftIO $ modifyIORef' unreadyChildren succ

1271 liftIO $ modifyIORef' unreadyChildren succ

455 let ready = do

1272 let ready = do

456 old <- liftIO $ readIORef unreadyChildren

1273 old <- liftIO $ readIORef unreadyChildren

457 let new = pred old

1274 let new = pred old

458 liftIO $ writeIORef unreadyChildren $! new

1275 liftIO $ writeIORef unreadyChildren $! new

459− when (new == 0) $ _immediateDomBuilderEnv_commitAction env

1276+ when (new == 0) commitAction

460 requestDomAction_ $ ready <$ eOnce

1277 requestDomAction_ $ ready <$ eOnce

461 notReady = do

1278 notReady = do

462− env <- ImmediateDomBuilderT ask

1279+ unreadyChildren <- askUnreadyChildren

463− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

464 liftIO $ modifyIORef' unreadyChildren succ

1280 liftIO $ modifyIORef' unreadyChildren succ

465

1281

466−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where

1282+data HydrationDomSpace

467− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace

1283+

1284+instance DomSpace HydrationDomSpace where

1285+ type EventSpec HydrationDomSpace = GhcjsEventSpec

1286+ type RawDocument HydrationDomSpace = DOM.Document

1287+ type RawTextNode HydrationDomSpace = ()

1288+ type RawCommentNode HydrationDomSpace = ()

1289+ type RawElement HydrationDomSpace = ()

1290+ type RawInputElement HydrationDomSpace = ()

1291+ type RawTextAreaElement HydrationDomSpace = ()

1292+ type RawSelectElement HydrationDomSpace = ()

1293+ addEventSpecFlags _ en f es = es

1294+ { _ghcjsEventSpec_filters =

1295+ let f' = Just . GhcjsEventFilter . \case

1296+ Nothing -> \evt -> do

1297+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)

1298+ return (f mEventResult, return mEventResult)

1299+ Just (GhcjsEventFilter oldFilter) -> \evt -> do

1300+ (oldFlags, oldContinuation) <- oldFilter evt

1301+ mEventResult <- oldContinuation

1302+ let newFlags = oldFlags <> f mEventResult

1303+ return (newFlags, return mEventResult)

1304+ in DMap.alter f' en $ _ghcjsEventSpec_filters es

1305+ }

1306+

1307+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT HydrationDomSpace t m) where

1308+ type DomBuilderSpace (HydrationDomBuilderT HydrationDomSpace t m) = HydrationDomSpace

1309+ {-# INLINABLE element #-}

1310+ element = elementInternal

468 {-# INLINABLE textNode #-}

1311 {-# INLINABLE textNode #-}

469− textNode (TextNodeConfig initialContents mSetContents) = do

470− n <- textNodeInternal initialContents

1312+ textNode = textNodeInternal

471− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

472− return $ TextNode n

473 {-# INLINABLE commentNode #-}

1313 {-# INLINABLE commentNode #-}

474− commentNode (CommentNodeConfig initialContents mSetContents) = do

475− n <- commentNodeInternal initialContents

1314+ commentNode = commentNodeInternal

476− mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

1315+ {-# INLINABLE inputElement #-}

477− return $ CommentNode n

1316+ inputElement = inputElementInternal

1317+ {-# INLINABLE textAreaElement #-}

1318+ textAreaElement = textAreaElementInternal

1319+ {-# INLINABLE selectElement #-}

1320+ selectElement = selectElementInternal

1321+ placeRawElement () = pure ()

1322+ wrapRawElement () _cfg = pure $ Element (EventSelector $ const never) ()

1323+

1324+instance SupportsHydrationDomBuilder t m => DomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where

1325+ type DomBuilderSpace (HydrationDomBuilderT GhcjsDomSpace t m) = GhcjsDomSpace

478 {-# INLINABLE element #-}

1326 {-# INLINABLE element #-}

479− element elementTag cfg child = fst <$> makeElement elementTag cfg child

1327+ element = elementImmediate

1328+ {-# INLINABLE textNode #-}

1329+ textNode = fmap TextNode . textNodeImmediate

1330+ {-# INLINABLE commentNode #-}

1331+ commentNode = fmap CommentNode . commentNodeImmediate

480 {-# INLINABLE inputElement #-}

1332 {-# INLINABLE inputElement #-}

481− inputElement cfg = do

1333+ inputElement = inputElementImmediate

482− ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

483− let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

484− Input.setValue domInputElement $ cfg ^. inputElementConfig_initialValue

485− v0 <- Input.getValue domInputElement

486− let getMyValue = Input.getValue domInputElement

487− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

488− valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

489− Nothing -> return never

490− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

491− Input.setValue domInputElement v'

492− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

493− v <- holdDyn v0 $ leftmost

494− [ valueChangedBySetValue

495− , valueChangedByUI

496− ]

497− Input.setChecked domInputElement $ _inputElementConfig_initialChecked cfg

498− checkedChangedByUI <- wrapDomEvent domInputElement (`on` Events.click) $ do

499− Input.getChecked domInputElement

500− checkedChangedBySetChecked <- case _inputElementConfig_setChecked cfg of

501− Nothing -> return never

502− Just eNewchecked -> requestDomAction $ ffor eNewchecked $ \newChecked -> do

503− oldChecked <- Input.getChecked domInputElement

504− Input.setChecked domInputElement newChecked

505− return $ if newChecked /= oldChecked

506− then Just newChecked

507− else Nothing

508− c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

509− [ fmapMaybe id checkedChangedBySetChecked

510− , checkedChangedByUI

511− ]

512− let initialFocus = False --TODO: Is this correct?

513− hasFocus <- holdDyn initialFocus $ leftmost

514− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

515− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

516− ]

517− files <- holdDyn mempty <=< wrapDomEvent domInputElement (`on` Events.change) $ do

518− mfiles <- Input.getFiles domInputElement

519− let getMyFiles xs = fmap catMaybes . mapM (FileList.item xs) . flip take [0..] . fromIntegral =<< FileList.getLength xs

520− maybe (return []) getMyFiles mfiles

521− checked <- holdUniqDyn c

522− return $ InputElement

523− { _inputElement_value = v

524− , _inputElement_checked = checked

525− , _inputElement_checkedChange = checkedChangedByUI

526− , _inputElement_input = valueChangedByUI

527− , _inputElement_hasFocus = hasFocus

528− , _inputElement_element = e

529− , _inputElement_raw = domInputElement

530− , _inputElement_files = files

531− }

532 {-# INLINABLE textAreaElement #-}

1334 {-# INLINABLE textAreaElement #-}

533− textAreaElement cfg = do --TODO

1335+ textAreaElement = textAreaElementImmediate

534− ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

535− let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

536− TextArea.setValue domTextAreaElement $ cfg ^. textAreaElementConfig_initialValue

537− v0 <- TextArea.getValue domTextAreaElement

538− let getMyValue = TextArea.getValue domTextAreaElement

539− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

540− valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

541− Nothing -> return never

542− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

543− TextArea.setValue domTextAreaElement v'

544− getMyValue -- We get the value after setting it in case the browser has mucked with it somehow

545− v <- holdDyn v0 $ leftmost

546− [ valueChangedBySetValue

547− , valueChangedByUI

548− ]

549− hasFocus <- mkHasFocus e

550− return $ TextAreaElement

551− { _textAreaElement_value = v

552− , _textAreaElement_input = valueChangedByUI

553− , _textAreaElement_hasFocus = hasFocus

554− , _textAreaElement_element = e

555− , _textAreaElement_raw = domTextAreaElement

556− }

557 {-# INLINABLE selectElement #-}

1336 {-# INLINABLE selectElement #-}

558− selectElement cfg child = do

1337+ selectElement = selectElementImmediate

559− ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child

560− let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

561− Select.setValue domSelectElement $ cfg ^. selectElementConfig_initialValue

562− v0 <- Select.getValue domSelectElement

563− let getMyValue = Select.getValue domSelectElement

564− valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)

565− valueChangedBySetValue <- case _selectElementConfig_setValue cfg of

566− Nothing -> return never

567− Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

568− Select.setValue domSelectElement 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

572− , valueChangedByUI

573− ]

574− hasFocus <- mkHasFocus e

575− let wrapped = SelectElement

576− { _selectElement_value = v

577− , _selectElement_change = valueChangedByUI

578− , _selectElement_hasFocus = hasFocus

579− , _selectElement_element = e

580− , _selectElement_raw = domSelectElement

581− }

582− return (wrapped, result)

583 placeRawElement = append . toNode

1338 placeRawElement = append . toNode

584− wrapRawElement = wrap

1339+ wrapRawElement e rawCfg = do

1340+ events <- askEvents

1341+ ctx <- askJSM

1342+ eventTriggerRefs <- wrap events e rawCfg

1343+ es <- newFanEventWithTrigger $ triggerBody ctx rawCfg events eventTriggerRefs e

1344+ pure $ Element es e

585

1345

586data FragmentState

1346data FragmentState

587 = FragmentState_Unmounted

1347 = FragmentState_Unmounted

@@ -601,21 +1361,21 @@ extractFragment fragment = do

601 extractBetweenExclusive (_immediateDomFragment_document fragment) before after

1361 extractBetweenExclusive (_immediateDomFragment_document fragment) before after

602 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted

1362 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted

603

1363

604−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where

1364+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where

605− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment

1365+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment

606 buildDomFragment w = do

1366 buildDomFragment w = do

607 df <- createDocumentFragment =<< askDocument

1367 df <- createDocumentFragment =<< askDocument

608 result <- flip localEnv w $ \env -> env

1368 result <- flip localEnv w $ \env -> env

609− { _immediateDomBuilderEnv_parent = toNode df

1369+ { _hydrationDomBuilderEnv_parent = Left $ toNode df

610 }

1370 }

611 state <- liftIO $ newIORef FragmentState_Unmounted

1371 state <- liftIO $ newIORef FragmentState_Unmounted

612 return (ImmediateDomFragment df state, result)

1372 return (ImmediateDomFragment df state, result)

613 mountDomFragment fragment setFragment = do

1373 mountDomFragment fragment setFragment = do

614− parent <- askParent

1374+ parent <- getParent

615 extractFragment fragment

1375 extractFragment fragment

616− before <- textNodeInternal ("" :: Text)

1376+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

617 appendChild_ parent $ _immediateDomFragment_document fragment

1377 appendChild_ parent $ _immediateDomFragment_document fragment

618− after <- textNodeInternal ("" :: Text)

1378+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

619 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment

1379 xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment

620 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do

1380 requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do

621 extractFragment previousFragment

1381 extractFragment previousFragment

@@ -624,12 +1384,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB

624 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

1384 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

625 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

1385 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

626

1386

1387+instance (Reflex t, Monad m, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (DomRenderHookT t m) where

1388+ runWithReplace a0 a' = DomRenderHookT $ runWithReplace (unDomRenderHookT a0) (fmapCheap unDomRenderHookT a')

1389+ traverseIntMapWithKeyWithAdjust f m = DomRenderHookT . traverseIntMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m

1390+ traverseDMapWithKeyWithAdjust f m = DomRenderHookT . traverseDMapWithKeyWithAdjust (\k -> unDomRenderHookT . f k) m

1391+ traverseDMapWithKeyWithAdjustWithMove f m = DomRenderHookT . traverseDMapWithKeyWithAdjustWithMove (\k -> unDomRenderHookT . f k) m

1392+

627−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where

1393+instance (Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => Adjustable t (HydrationDomBuilderT s t m) where

628 {-# INLINABLE runWithReplace #-}

1394 {-# INLINABLE runWithReplace #-}

629 runWithReplace a0 a' = do

1395 runWithReplace a0 a' = do

630− initialEnv <- ImmediateDomBuilderT ask

1396+ initialEnv <- HydrationDomBuilderT ask

631− before <- textNodeInternal ("" :: Text)

1397+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv

1398+ (hydrateStart, before, beforeKey) <- skipToReplaceStart

632− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

1399+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

633 haveEverBeenReady <- liftIO $ newIORef False

1400 haveEverBeenReady <- liftIO $ newIORef False

634 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM

1401 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM

635 let myCommitAction = do

1402 let myCommitAction = do

@@ -640,79 +1407,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

640 old <- liftIO $ readIORef parentUnreadyChildren

1407 old <- liftIO $ readIORef parentUnreadyChildren

641 let new = pred old

1408 let new = pred old

642 liftIO $ writeIORef parentUnreadyChildren $! new

1409 liftIO $ writeIORef parentUnreadyChildren $! new

643− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

1410+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

644 -- We draw 'after' in this roundabout way to avoid using MonadFix

1411 -- We draw 'after' in this roundabout way to avoid using MonadFix

645 doc <- askDocument

1412 doc <- askDocument

646− after <- createTextNode doc ("" :: Text)

1413+ parent <- getParent

1414+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey

647 let drawInitialChild = do

1415 let drawInitialChild = do

1416+ h <- liftIO $ readIORef hydrating

1417+ p' <- case h of

1418+ HydrationMode_Hydrating -> pure parent

1419+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

648 unreadyChildren <- liftIO $ newIORef 0

1420 unreadyChildren <- liftIO $ newIORef 0

649− let f = do

1421+ let a0' = case h of

650− result <- a0

1422+ HydrationMode_Hydrating -> a0

651− append $ toNode after

1423+ HydrationMode_Immediate -> do

652− return result

1424+ a <- a0

1425+ insertBefore p' =<< liftIO (readIORef after)

1426+ pure a

1427+ delayed <- case h of

1428+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()

1429+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv

653− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv

1430+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv

654− { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

1431+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

655− , _immediateDomBuilderEnv_commitAction = myCommitAction

1432+ , _hydrationDomBuilderEnv_commitAction = myCommitAction

1433+ , _hydrationDomBuilderEnv_parent = Left p'

1434+ , _hydrationDomBuilderEnv_delayed = delayed

656 }

1435 }

1436+ dom <- case h of

1437+ HydrationMode_Hydrating -> liftIO $ readIORef delayed

1438+ HydrationMode_Immediate -> pure $ pure ()

657 liftIO $ readIORef unreadyChildren >>= \case

1439 liftIO $ readIORef unreadyChildren >>= \case

658 0 -> writeIORef haveEverBeenReady True

1440 0 -> writeIORef haveEverBeenReady True

659 _ -> modifyIORef' parentUnreadyChildren succ

1441 _ -> modifyIORef' parentUnreadyChildren succ

660− return result

1442+ return (dom, result)

661 a'' <- numberOccurrences a'

1443 a'' <- numberOccurrences a'

662− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

1444+ ((hydrate0, result0), child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

1445+ h <- liftIO $ readIORef hydrating

1446+ p' <- case h of

1447+ HydrationMode_Hydrating -> pure parent

663− df <- createDocumentFragment doc

1448+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

664 unreadyChildren <- liftIO $ newIORef 0

1449 unreadyChildren <- liftIO $ newIORef 0

665 let commitAction = do

1450 let commitAction = do

666 c <- liftIO $ readIORef currentCohort

1451 c <- liftIO $ readIORef currentCohort

667 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this

1452 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this

1453+ !before' <- liftIO $ readIORef before

1454+ !after' <- liftIO $ readIORef after

668− deleteBetweenExclusive before after

1455+ deleteBetweenExclusive before' after'

669− insertBefore df after

1456+ insertBefore p' after'

670 liftIO $ writeIORef currentCohort cohortId

1457 liftIO $ writeIORef currentCohort cohortId

671 myCommitAction

1458 myCommitAction

1459+ delayed <- case h of

1460+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()

1461+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv

672− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv

1462+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv

673− { _immediateDomBuilderEnv_parent = toNode df

1463+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

674− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

1464+ , _hydrationDomBuilderEnv_commitAction = case h of

675− , _immediateDomBuilderEnv_commitAction = commitAction

1465+ HydrationMode_Hydrating -> myCommitAction

1466+ HydrationMode_Immediate -> commitAction

1467+ , _hydrationDomBuilderEnv_parent = Left p'

1468+ , _hydrationDomBuilderEnv_delayed = delayed

676− }

1469+ }

1470+ dom <- case h of

1471+ HydrationMode_Hydrating -> liftIO $ readIORef delayed

1472+ HydrationMode_Immediate -> pure $ pure ()

677 uc <- liftIO $ readIORef unreadyChildren

1473 uc <- liftIO $ readIORef unreadyChildren

678 let commitActionToRunNow = if uc == 0

1474 let commitActionToRunNow = if uc == 0

679− then Just commitAction

1475+ then Just $ commitAction

680 else Nothing -- A child will run it when unreadyChildren is decremented to 0

1476 else Nothing -- A child will run it when unreadyChildren is decremented to 0

1477+ actions = case h of

1478+ HydrationMode_Hydrating -> Left dom

681− return (commitActionToRunNow, result)

1479+ HydrationMode_Immediate -> Right commitActionToRunNow

1480+ return (actions, result)

1481+ let (hydrate', commitAction) = fanEither $ fmap fst child'

1482+ addHydrationStepWithSetup (hold hydrate0 hydrate') $ \contents -> do

1483+ hydrateStart

1484+ join $ sample contents

1485+ hydrateEnd

682− requestDomAction_ $ fmapMaybe fst child'

1486+ requestDomAction_ $ fmapMaybe id commitAction

683 return (result0, snd <$> child')

1487 return (result0, snd <$> child')

1488+

684 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

1489 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

685 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'

1490 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'

686 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

1491 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

687 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'

1492 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'

688 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

1493 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

689 traverseDMapWithKeyWithAdjustWithMove = do

1494 traverseDMapWithKeyWithAdjustWithMove = do

690− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

1495+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) old = do

691− 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)

1496+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState (Some k)))) a)

692 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case

1497 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case

693− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do

1498+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete

694− readIORef sRef >>= \case

1499+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do

1500+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

695 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete

1501 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete

696 ChildReadyState_Unready _ -> do

1502 ChildReadyState_Unready _ -> do

697− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

1503+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

698− return $ PatchDMapWithMove.From_Insert $ Constant sRef

1504+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)

699 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete

1505 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete

700 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey

1506 PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey

701− deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)

1507+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState (Some k)))) (ComposeMaybe k) a -> IO (Constant () a)

702 deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do

1508 deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do

703− writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases

1509+ writeIORef sRef $ ChildReadyState_Unready $ This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases

704 return $ Constant ()

1510 return $ Constant ()

705 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p

1511 p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p

706 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old

1512 _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old

707 return $ applyAlways p' old

1513 return $ applyAlways p' old

708− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do

1514+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholder (p_ :: PatchDMapWithMove k (Compose (TraverseChild t m (Some k)) v')) -> do

709 let p = unPatchDMapWithMove p_

1515 let p = unPatchDMapWithMove p_

710 phsBefore <- liftIO $ readIORef placeholders

1516 phsBefore <- liftIO $ readIORef placeholders

711− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

712− 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)

1517+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)

713 collectIfMoved k e = do

1518 collectIfMoved k e = do

714− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before

1519+ let mThisPlaceholder = Map.lookup (This k) phsBefore -- Will be Nothing if this element wasn't present before

715− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore

1520+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsBefore

716 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of

1521 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of

717 False -> do

1522 False -> do

718 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

1523 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

@@ -720,13 +1525,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

720 True -> do

1525 True -> do

721 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder

1526 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder

722 collected <- DMap.traverseWithKey collectIfMoved p

1527 collected <- DMap.traverseWithKey collectIfMoved p

723− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this

1528+ let !phsAfter = fromMaybe phsBefore $ apply filtered phsBefore

1529+ weakened :: PatchMapWithMove (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))

1530+ weakened = weakenPatchDMapWithMoveWith (_traverseChild_mode . getCompose) p_

1531+ filtered :: PatchMapWithMove (Some k) DOM.Text

1532+ filtered = PatchMapWithMove $ flip Map.mapMaybe (unPatchMapWithMove weakened) $ \(PatchMapWithMove.NodeInfo from to) -> flip PatchMapWithMove.NodeInfo to <$> case from of

1533+ PatchMapWithMove.From_Insert (Left _hydration) -> Nothing

1534+ PatchMapWithMove.From_Insert (Right immediate) -> Just $ PatchMapWithMove.From_Insert $ _traverseChildImmediate_placeholder immediate

1535+ PatchMapWithMove.From_Delete -> Just $ PatchMapWithMove.From_Delete

1536+ PatchMapWithMove.From_Move k -> Just $ PatchMapWithMove.From_Move k

724− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)

1537+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose (TraverseChild t m (Some k)) v') a -> JSM (Constant () a)

725 placeFragment k e = do

1538 placeFragment k e = do

726− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter

1539+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsAfter

727 case PatchDMapWithMove._nodeInfo_from e of

1540 case PatchDMapWithMove._nodeInfo_from e of

728− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do

1541+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of

1542+ Left _ -> pure ()

729− df `insertBefore` nextPlaceholder

1543+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

730 PatchDMapWithMove.From_Delete -> do

1544 PatchDMapWithMove.From_Delete -> do

731 return ()

1545 return ()

732 PatchDMapWithMove.From_Move fromKey -> do

1546 PatchDMapWithMove.From_Move fromKey -> do

@@ -737,105 +1551,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

737 liftIO $ writeIORef placeholders $! phsAfter

1551 liftIO $ writeIORef placeholders $! phsAfter

738

1552

739{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}

1553{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}

1554+traverseDMapWithKeyWithAdjust'

740−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 -> ImmediateDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> ImmediateDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))

1555+ :: 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)

1556+ => (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))

1557+ -> DMap k v

1558+ -> Event t (PatchDMap k v)

1559+ -> HydrationDomBuilderT s t m (DMap k v', Event t (PatchDMap k v'))

741traverseDMapWithKeyWithAdjust' = do

1560traverseDMapWithKeyWithAdjust' = do

742− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

1561+ let updateChildUnreadiness (p :: PatchDMap k (Compose (TraverseChild t m (Some k)) v')) old = do

743− let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)

1562+ let new :: forall a. k a -> ComposeMaybe (Compose (TraverseChild t m (Some k)) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState (Some k)))) a)

744 new k (ComposeMaybe m) = ComposeMaybe <$> case m of

1563 new k (ComposeMaybe m) = ComposeMaybe <$> case m of

745 Nothing -> return Nothing

1564 Nothing -> return Nothing

746− Just (Compose (_, _, sRef, _)) -> do

1565+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing

747− readIORef sRef >>= \case

1566+ Just (Compose (TraverseChild (Right immediate) _)) -> do

1567+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

748 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

1568 ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

749 ChildReadyState_Unready _ -> do

1569 ChildReadyState_Unready _ -> do

750− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

1570+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

751− return $ Just $ Constant sRef

1571+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)

752 delete _ (Constant sRef) = do

1572 delete _ (Constant sRef) = do

753 writeIORef sRef $ ChildReadyState_Unready Nothing

1573 writeIORef sRef $ ChildReadyState_Unready Nothing

754 return $ Constant ()

1574 return $ Constant ()

755 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p

1575 p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p

756 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old

1576 _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old

757 return $ applyAlways p' old

1577 return $ applyAlways p' old

758− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do

1578+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do

759 phs <- liftIO $ readIORef placeholders

1579 phs <- liftIO $ readIORef placeholders

760− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do

1580+ forM_ (DMap.toList patch) $ \(k :=> ComposeMaybe mv) -> do

761− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

762− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

1581+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phs

1582+ -- Delete old node

1583+ forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do

763− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

1584+ thisPlaceholder `deleteUpTo` nextPlaceholder

1585+ -- Insert new node

1586+ forM_ mv $ \(Compose (TraverseChild e _)) -> case e of

1587+ Left _hydration -> pure ()

1588+ Right immediate -> do

764− forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder

1589+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

1590+ let weakened :: PatchMap (Some k) (Either (TraverseChildHydration t m) (TraverseChildImmediate (Some k)))

1591+ weakened = weakenPatchDMapWith (_traverseChild_mode . getCompose) $ PatchDMap patch

1592+ filtered :: PatchMap (Some k) DOM.Text

1593+ filtered = PatchMap $ flip Map.mapMaybe (unPatchMap weakened) $ \case

1594+ Nothing -> Just Nothing -- deletion

1595+ Just (Left _) -> Nothing

1596+ Just (Right immediate) -> Just $ Just $ _traverseChildImmediate_placeholder immediate

765− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs

1597+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs

766

1598

767{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}

1599{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}

768−traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (Adjustable t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> ImmediateDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> ImmediateDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))

1600+traverseIntMapWithKeyWithAdjust'

1601+ :: forall s t m v v'. (Adjustable t m, MonadJSM m, MonadFix m, PrimMonad m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)

1602+ => (IntMap.Key -> v -> HydrationDomBuilderT s t m v')

1603+ -> IntMap v

1604+ -> Event t (PatchIntMap v)

1605+ -> HydrationDomBuilderT s t m (IntMap v', Event t (PatchIntMap v'))

769traverseIntMapWithKeyWithAdjust' = do

1606traverseIntMapWithKeyWithAdjust' = do

770− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do

1607+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (TraverseChild t m Int v')) old = do

771− let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))

1608+ let new :: IntMap.Key -> Maybe (TraverseChild t m Int v') -> IO (Maybe (IORef (ChildReadyState Int)))

772 new k m = case m of

1609 new k m = case m of

773 Nothing -> return Nothing

1610 Nothing -> return Nothing

774− Just (_, _, sRef, _) -> do

1611+ Just (TraverseChild (Left _hydration) _) -> pure Nothing

1612+ Just (TraverseChild (Right immediate) _) -> do

1613+ let sRef = _traverseChildImmediate_childReadyState immediate

775 readIORef sRef >>= \case

1614 readIORef sRef >>= \case

776− ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready

1615+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

777− ChildReadyStateInt_Unready _ -> do

1616+ ChildReadyState_Unready _ -> do

778− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k

1617+ writeIORef sRef $ ChildReadyState_Unready $ Just k

779 return $ Just sRef

1618 return $ Just sRef

780 delete _ sRef = do

1619 delete _ sRef = do

781− writeIORef sRef $ ChildReadyStateInt_Unready Nothing

1620+ writeIORef sRef $ ChildReadyState_Unready Nothing

782 return ()

1621 return ()

783 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner

1622 p' <- PatchIntMap <$> IntMap.traverseWithKey new pInner

784 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old

1623 _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old

785 return $ applyAlways p' old

1624 return $ applyAlways p' old

786− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do

1625+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do

787 phs <- liftIO $ readIORef placeholders

1626 phs <- liftIO $ readIORef placeholders

788 forM_ (IntMap.toList p) $ \(k, mv) -> do

1627 forM_ (IntMap.toList p) $ \(k, mv) -> do

789− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

790 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs

1628 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs

1629+ -- Delete old node

791 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

1630 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

1631+ -- Insert new node

1632+ forM_ mv $ \(TraverseChild e _) -> case e of

1633+ Left _hydration -> pure ()

1634+ Right immediate -> do

792− forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder

1635+ _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

1636+ let filtered :: PatchIntMap DOM.Text

1637+ filtered = PatchIntMap $ flip IntMap.mapMaybe p $ \case

1638+ Nothing -> Just Nothing -- deletion

1639+ Just tc

1640+ | Right immediate <- _traverseChild_mode tc -> Just $ Just $ _traverseChildImmediate_placeholder immediate

1641+ | otherwise -> Nothing

793− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs

1642+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs

1643+

1644+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'

1645+ :: (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM v')

1646+ -> IntMap v

1647+ -> Event Spider (PatchIntMap v)

1648+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

1649+ #-}

794

1650

795−#if MIN_VERSION_base(4,9,0)

1651+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'

796−data ChildReadyState k

1652+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM v')

797−#else

1653+ -> IntMap v

798−data ChildReadyState (k :: * -> *)

1654+ -> Event Spider (PatchIntMap v)

799−#endif

1655+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

1656+ #-}

1657+

1658+data ChildReadyState a

800 = ChildReadyState_Ready

1659 = ChildReadyState_Ready

801− | ChildReadyState_Unready !(Maybe (Some k))

1660+ | ChildReadyState_Unready !(Maybe a)

802 deriving (Show, Read, Eq, Ord)

1661 deriving (Show, Read, Eq, Ord)

803

1662

804−data ChildReadyStateInt

1663+insertAfterPreviousNode :: (Monad m, MonadJSM m) => DOM.IsNode node => node -> HydrationRunnerT t m ()

805− = ChildReadyStateInt_Ready

1664+insertAfterPreviousNode node = do

806− | ChildReadyStateInt_Unready !(Maybe Int)

1665+ parent <- askParent

807− deriving (Show, Read, Eq, Ord)

1666+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode

1667+ Node.insertBefore_ parent node nextNode

1668+ setPreviousNode $ Just $ toNode node

808

1669

809−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}

1670+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}

810−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.

1671+hoistTraverseWithKeyWithAdjust

1672+ ::

811 ( Adjustable t m

1673 ( Adjustable t m

1674+ , MonadHold t m

1675+ , DMap.GCompare k

812 , MonadIO m

1676 , MonadIO m

813 , MonadJSM m

1677 , MonadJSM m

814− , MonadFix m

815 , PrimMonad m

1678 , PrimMonad m

816− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

1679+ , MonadFix m

817− , Functor p

1680+ , Patch (p k v)

1681+ , Patch (p k (Constant Int))

1682+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)

1683+ , Patch (p k (Compose (TraverseChild t m (Some k)) v'))

1684+ , PatchTarget (p k (Compose (TraverseChild t m (Some k)) v')) ~ DMap k (Compose (TraverseChild t m (Some k)) v')

1685+ , Monoid (p k (Compose (TraverseChild t m (Some k)) v'))

1686+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document

818 )

1687 )

819− => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

1688+ => (forall vv vv'.

820− -> IntMap v

1689+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))

1690+ -> DMap k vv

821− -> Event t (p v)

1691+ -> Event t (p k vv)

822− -> 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')))

1692+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))

823− ) -- ^ The base monad's traversal

1693+ -- ^ The base monad's traversal

1694+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv')

1695+ -- ^ A way of mapping over the patch type

1696+ -> (p k (Compose (TraverseChild t m (Some k)) v') -> DMap k (Constant (IORef (ChildReadyState (Some k)))) -> IO (DMap k (Constant (IORef (ChildReadyState (Some k))))))

824− -> (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

1697+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state

825− -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM

1698+ -> (IORef (Map.Map (Some k) DOM.Text) -> DOM.Text -> p k (Compose (TraverseChild t m (Some k)) v') -> JSM ())

826− -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')

1699+ -- ^ Apply a patch to the DOM

827− -> IntMap v

1700+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))

1701+ -> DMap k v

828− -> Event t (p v)

1702+ -> Event t (p k v)

829− -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))

1703+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))

830−hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

1704+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

831− initialEnv <- ImmediateDomBuilderT ask

1705+ doc <- askDocument

1706+ initialEnv <- HydrationDomBuilderT ask

832− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

1707+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

833− pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty

1708+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState (Some k)))), p k (Compose (TraverseChild t m (Some k)) v')) <- liftIO $ newIORef mempty

834 haveEverBeenReady <- liftIO $ newIORef False

1709 haveEverBeenReady <- liftIO $ newIORef False

835− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"

1710+ placeholders <- liftIO $ newIORef Map.empty

836− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"

1711+ lastPlaceholder <- createTextNode doc ("" :: Text)

837 let applyDomUpdate p = do

1712 let applyDomUpdate p = do

838− applyDomUpdate_ placeholders lastPlaceholderRef p

1713+ applyDomUpdate_ placeholders lastPlaceholder p

839 markSelfReady

1714 markSelfReady

840 liftIO $ writeIORef pendingChange $! mempty

1715 liftIO $ writeIORef pendingChange $! mempty

841 markSelfReady = do

1716 markSelfReady = do

@@ -846,86 +1721,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_

846 old <- liftIO $ readIORef parentUnreadyChildren

1721 old <- liftIO $ readIORef parentUnreadyChildren

847 let new = pred old

1722 let new = pred old

848 liftIO $ writeIORef parentUnreadyChildren $! new

1723 liftIO $ writeIORef parentUnreadyChildren $! new

849− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

1724+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

850− markChildReady :: IORef ChildReadyStateInt -> JSM ()

1725+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()

851 markChildReady childReadyState = do

1726 markChildReady childReadyState = do

852 liftIO (readIORef childReadyState) >>= \case

1727 liftIO (readIORef childReadyState) >>= \case

853− ChildReadyStateInt_Ready -> return ()

1728+ ChildReadyState_Ready -> return ()

854− ChildReadyStateInt_Unready countedAt -> do

1729+ ChildReadyState_Unready countedAt -> do

855− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready

1730+ liftIO $ writeIORef childReadyState ChildReadyState_Ready

856 case countedAt of

1731 case countedAt of

857 Nothing -> return ()

1732 Nothing -> return ()

858− Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set

1733+ Just (This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set

859 (oldUnready, p) <- liftIO $ readIORef pendingChange

1734 (oldUnready, p) <- liftIO $ readIORef pendingChange

860− when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null

1735+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null

861− let newUnready = IntMap.delete k oldUnready

1736+ let newUnready = DMap.delete k oldUnready

862 liftIO $ writeIORef pendingChange (newUnready, p)

1737 liftIO $ writeIORef pendingChange (newUnready, p)

863− when (IntMap.null newUnready) $ do

1738+ when (DMap.null newUnready) $ do

864 applyDomUpdate p

1739 applyDomUpdate p

1740+ (children0 :: DMap k (Compose (TraverseChild t m (Some k)) v'), children' :: Event t (p k (Compose (TraverseChild t m (Some k)) v')))

865− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

1741+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

866− let processChild k (_, _, sRef, _) = do

1742+ let processChild k (Compose (TraverseChild e _)) = case e of

867− readIORef sRef >>= \case

1743+ Left _ -> pure $ ComposeMaybe Nothing

868− ChildReadyStateInt_Ready -> return Nothing

1744+ Right immediate -> ComposeMaybe <$> do

869− ChildReadyStateInt_Unready _ -> do

1745+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

870− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k

1746+ ChildReadyState_Ready -> return Nothing

871− return $ Just sRef

1747+ ChildReadyState_Unready _ -> do

1748+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1749+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)

872− initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0

1750+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0

873− liftIO $ if IntMap.null initialUnready

1751+ liftIO $ if DMap.null initialUnready

874 then writeIORef haveEverBeenReady True

1752 then writeIORef haveEverBeenReady True

875 else do

1753 else do

876 modifyIORef' parentUnreadyChildren succ

1754 modifyIORef' parentUnreadyChildren succ

877 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

1755 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

878− let result0 = IntMap.map (\(_, _, _, v) -> v) children0

1756+ getHydrationMode >>= \case

879− placeholders0 = fmap (\(_, ph, _, _) -> ph) children0

1757+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

880− result' = ffor children' $ fmap $ \(_, _, _, r) -> r

1758+ dm :: DMap k (Compose (TraverseChild t m (Some k)) v') <- sample $ currentIncremental children

881− liftIO $ writeIORef placeholders $! placeholders0

1759+ phs <- traverse id $ weakenDMapWith (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode . getCompose) dm

882− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0

1760+ liftIO $ writeIORef placeholders $! phs

883− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

1761+ insertAfterPreviousNode lastPlaceholder

1762+ HydrationMode_Immediate -> do

1763+ let activate i = do

1764+ append $ toNode $ _traverseChildImmediate_fragment i

1765+ pure $ _traverseChildImmediate_placeholder i

1766+ phs <- traverse id $ weakenDMapWith (either (error "impossible") activate . _traverseChild_mode . getCompose) children0

1767+ liftIO $ writeIORef placeholders $! phs

1768+ append $ toNode lastPlaceholder

884 requestDomAction_ $ ffor children' $ \p -> do

1769 requestDomAction_ $ ffor children' $ \p -> do

885 (oldUnready, oldP) <- liftIO $ readIORef pendingChange

1770 (oldUnready, oldP) <- liftIO $ readIORef pendingChange

886 newUnready <- liftIO $ updateChildUnreadiness p oldUnready

1771 newUnready <- liftIO $ updateChildUnreadiness p oldUnready

887 let !newP = p <> oldP

1772 let !newP = p <> oldP

888 liftIO $ writeIORef pendingChange (newUnready, newP)

1773 liftIO $ writeIORef pendingChange (newUnready, newP)

889− when (IntMap.null newUnready) $ do

1774+ when (DMap.null newUnready) $ do

890 applyDomUpdate newP

1775 applyDomUpdate newP

1776+ let result0 = DMap.map (_traverseChild_result . getCompose) children0

1777+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose

891 return (result0, result')

1778 return (result0, result')

892

1779

893−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}

1780+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}

894−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

1781+hoistTraverseIntMapWithKeyWithAdjust ::

895 ( Adjustable t m

1782 ( Adjustable t m

896 , MonadHold t m

1783 , MonadHold t m

897− , DMap.GCompare k

898− , MonadIO m

899 , MonadJSM m

1784 , MonadJSM m

900− , PrimMonad m

901 , MonadFix m

1785 , MonadFix m

902− , Patch (p k v)

1786+ , PrimMonad m

903− , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)

1787+ , Monoid (p (TraverseChild t m Int v'))

904− , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))

1788+ , Functor p

905− , Patch (p k (Constant Int))

1789+ , PatchTarget (p (HydrationRunnerT t m ())) ~ IntMap (HydrationRunnerT t m ())

1790+ , PatchTarget (p (TraverseChild t m Int v')) ~ IntMap (TraverseChild t m Int v')

1791+ , Patch (p (HydrationRunnerT t m ()))

1792+ , Patch (p (TraverseChild t m Int v'))

1793+ , RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document

906 )

1794 )

907− => (forall vv vv'.

1795+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))

908− (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))

1796+ -> IntMap v

909− -> DMap k vv

910− -> Event t (p k vv)

1797+ -> Event t (p v)

911− -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))

1798+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))

912− ) -- ^ The base monad's traversal

1799+ -- ^ The base monad's traversal

913− -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type

1800+ -> (p (TraverseChild t m Int v')

1801+ -> IntMap (IORef (ChildReadyState Int))

1802+ -> IO (IntMap (IORef (ChildReadyState Int))))

914− -> (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

1803+ -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state

915− -> (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

1804+ -> (IORef (IntMap DOM.Text)

916− -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))

1805+ -> DOM.Text

917− -> DMap k v

1806+ -> p (TraverseChild t m Int v')

1807+ -> JSM ())

1808+ -- ^ Apply a patch to the DOM

1809+ -> (IntMap.Key -> v -> HydrationDomBuilderT s t m v')

1810+ -> IntMap v

918− -> Event t (p k v)

1811+ -> Event t (p v)

919− -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))

1812+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))

920−hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

1813+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

921− initialEnv <- ImmediateDomBuilderT ask

1814+ doc <- askDocument

1815+ initialEnv <- HydrationDomBuilderT ask

922− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

1816+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

923− pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty

1817+ pendingChange :: IORef (IntMap (IORef (ChildReadyState Int)), p (TraverseChild t m Int v')) <- liftIO $ newIORef mempty

924 haveEverBeenReady <- liftIO $ newIORef False

1818 haveEverBeenReady <- liftIO $ newIORef False

925− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"

1819+ placeholders <- liftIO $ newIORef IntMap.empty

926− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"

1820+ lastPlaceholder <- createTextNode doc ("" :: Text)

927 let applyDomUpdate p = do

1821 let applyDomUpdate p = do

928− applyDomUpdate_ placeholders lastPlaceholderRef p

1822+ applyDomUpdate_ placeholders lastPlaceholder p

929 markSelfReady

1823 markSelfReady

930 liftIO $ writeIORef pendingChange $! mempty

1824 liftIO $ writeIORef pendingChange $! mempty

931 markSelfReady = do

1825 markSelfReady = do

@@ -936,8 +1830,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

936 old <- liftIO $ readIORef parentUnreadyChildren

1830 old <- liftIO $ readIORef parentUnreadyChildren

937 let new = pred old

1831 let new = pred old

938 liftIO $ writeIORef parentUnreadyChildren $! new

1832 liftIO $ writeIORef parentUnreadyChildren $! new

939− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

1833+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

940− markChildReady :: IORef (ChildReadyState k) -> JSM ()

1834+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()

941 markChildReady childReadyState = do

1835 markChildReady childReadyState = do

942 liftIO (readIORef childReadyState) >>= \case

1836 liftIO (readIORef childReadyState) >>= \case

943 ChildReadyState_Ready -> return ()

1837 ChildReadyState_Ready -> return ()

@@ -945,82 +1839,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

945 liftIO $ writeIORef childReadyState ChildReadyState_Ready

1839 liftIO $ writeIORef childReadyState ChildReadyState_Ready

946 case countedAt of

1840 case countedAt of

947 Nothing -> return ()

1841 Nothing -> return ()

948− Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set

1842+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set

949 (oldUnready, p) <- liftIO $ readIORef pendingChange

1843 (oldUnready, p) <- liftIO $ readIORef pendingChange

950− when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null

1844+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null

951− let newUnready = DMap.delete k oldUnready

1845+ let newUnready = IntMap.delete k oldUnready

952 liftIO $ writeIORef pendingChange (newUnready, p)

1846 liftIO $ writeIORef pendingChange (newUnready, p)

953− when (DMap.null newUnready) $ do

1847+ when (IntMap.null newUnready) $ do

954 applyDomUpdate p

1848 applyDomUpdate p

1849+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))

955− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

1850+ <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

956− let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do

1851+ let processChild k (TraverseChild e _) = case e of

957− readIORef sRef >>= \case

1852+ Left _ -> pure Nothing

1853+ Right immediate -> do

1854+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

958− ChildReadyState_Ready -> return Nothing

1855+ ChildReadyState_Ready -> return Nothing

959− ChildReadyState_Unready _ -> do

1856+ ChildReadyState_Unready _ -> do

960− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

1857+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k

961− return $ Just $ Constant sRef

1858+ return $ Just (_traverseChildImmediate_childReadyState immediate)

962− initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0

1859+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0

963− liftIO $ if DMap.null initialUnready

1860+ liftIO $ if IntMap.null initialUnready

964 then writeIORef haveEverBeenReady True

1861 then writeIORef haveEverBeenReady True

965 else do

1862 else do

966 modifyIORef' parentUnreadyChildren succ

1863 modifyIORef' parentUnreadyChildren succ

967 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

1864 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

968− let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0

1865+ getHydrationMode >>= \case

969− placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0

1866+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

970− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r

1867+ dm :: IntMap (TraverseChild t m Int v') <- sample $ currentIncremental children

971− liftIO $ writeIORef placeholders $! placeholders0

1868+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm

972− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0

1869+ liftIO $ writeIORef placeholders $! phs

973− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

1870+ insertAfterPreviousNode lastPlaceholder

1871+ HydrationMode_Immediate -> do

1872+ let activate i = do

1873+ append $ toNode $ _traverseChildImmediate_fragment i

1874+ pure $ _traverseChildImmediate_placeholder i

1875+ phs <- traverse (either (error "impossible") activate . _traverseChild_mode) children0

1876+ liftIO $ writeIORef placeholders $! phs

1877+ append $ toNode lastPlaceholder

974 requestDomAction_ $ ffor children' $ \p -> do

1878 requestDomAction_ $ ffor children' $ \p -> do

975 (oldUnready, oldP) <- liftIO $ readIORef pendingChange

1879 (oldUnready, oldP) <- liftIO $ readIORef pendingChange

976 newUnready <- liftIO $ updateChildUnreadiness p oldUnready

1880 newUnready <- liftIO $ updateChildUnreadiness p oldUnready

977 let !newP = p <> oldP

1881 let !newP = p <> oldP

978 liftIO $ writeIORef pendingChange (newUnready, newP)

1882 liftIO $ writeIORef pendingChange (newUnready, newP)

979− when (DMap.null newUnready) $ do

1883+ when (IntMap.null newUnready) $ do

980 applyDomUpdate newP

1884 applyDomUpdate newP

1885+ let result0 = IntMap.map _traverseChild_result children0

1886+ result' = ffor children' $ fmap $ _traverseChild_result

981 return (result0, result')

1887 return (result0, result')

982

1888

1889+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust

1890+ :: ((IntMap.Key -> v -> DomRenderHookT Spider HydrationM (TraverseChild Spider HydrationM Int v'))

1891+ -> IntMap v

1892+ -> Event Spider (PatchIntMap v)

1893+ -> DomRenderHookT Spider HydrationM (IntMap (TraverseChild Spider HydrationM Int v'), Event Spider (PatchIntMap (TraverseChild Spider HydrationM Int v'))))

1894+ -> (PatchIntMap (TraverseChild Spider HydrationM Int v')

1895+ -> IntMap (IORef (ChildReadyState Int))

1896+ -> IO (IntMap (IORef (ChildReadyState Int))))

1897+ -> (IORef (IntMap DOM.Text)

1898+ -> DOM.Text

1899+ -> PatchIntMap (TraverseChild Spider HydrationM Int v')

1900+ -> JSM ())

1901+ -> (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM v')

1902+ -> IntMap v

1903+ -> Event Spider (PatchIntMap v)

1904+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

1905+ #-}

1906+

1907+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust

1908+ :: ((IntMap.Key -> v -> DomRenderHookT Spider HydrationM (TraverseChild Spider HydrationM Int v'))

1909+ -> IntMap v

1910+ -> Event Spider (PatchIntMap v)

1911+ -> DomRenderHookT Spider HydrationM (IntMap (TraverseChild Spider HydrationM Int v'), Event Spider (PatchIntMap (TraverseChild Spider HydrationM Int v'))))

1912+ -> (PatchIntMap (TraverseChild Spider HydrationM Int v')

1913+ -> IntMap (IORef (ChildReadyState Int))

1914+ -> IO (IntMap (IORef (ChildReadyState Int))))

1915+ -> (IORef (IntMap DOM.Text)

1916+ -> DOM.Text

1917+ -> PatchIntMap (TraverseChild Spider HydrationM Int v')

1918+ -> JSM ())

1919+ -> (IntMap.Key -> v -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM v')

1920+ -> IntMap v

1921+ -> Event Spider (PatchIntMap v)

1922+ -> HydrationDomBuilderT GhcjsDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

1923+ #-}

1924+

1925+data TraverseChildImmediate k = TraverseChildImmediate

1926+ { _traverseChildImmediate_fragment :: {-# UNPACK #-} !DOM.DocumentFragment

1927+ -- ^ Child is appended to this fragment

1928+ , _traverseChildImmediate_placeholder :: {-# UNPACK #-} !DOM.Text

1929+ -- ^ Placeholder reference

1930+ , _traverseChildImmediate_childReadyState :: {-# UNPACK #-} !(IORef (ChildReadyState k))

1931+ }

1932+

1933+newtype TraverseChildHydration t m = TraverseChildHydration

1934+ { _traverseChildHydration_delayed :: HydrationRunnerT t m DOM.Text

1935+ -- ^ Action to run at switchover, returns the placeholder

1936+ }

1937+

1938+data TraverseChild t m k a = TraverseChild

1939+ { _traverseChild_mode :: !(Either (TraverseChildHydration t m) (TraverseChildImmediate k))

1940+ , _traverseChild_result :: !a

1941+ } deriving Functor

1942+

983{-# INLINABLE drawChildUpdate #-}

1943{-# INLINABLE drawChildUpdate #-}

984−drawChildUpdate :: (MonadIO m, MonadJSM m)

1944+drawChildUpdate :: (MonadJSM m, Reflex t)

985− => ImmediateDomBuilderEnv t

1945+ => HydrationDomBuilderEnv t m

986 -> (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

1946 -> (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

987− -> ImmediateDomBuilderT t m (v' a)

1947+ -> HydrationDomBuilderT s t m (f a)

988− -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)

1948+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)

989drawChildUpdate initialEnv markReady child = do

1949drawChildUpdate initialEnv markReady child = do

990− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

1950+ let doc = _hydrationDomBuilderEnv_document initialEnv

991 unreadyChildren <- liftIO $ newIORef 0

1951 unreadyChildren <- liftIO $ newIORef 0

1952+ liftIO (readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv) >>= \case

1953+ HydrationMode_Hydrating -> do

1954+ childDelayedRef <- liftIO $ newIORef $ pure ()

1955+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv

1956+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1957+ , _hydrationDomBuilderEnv_delayed = childDelayedRef

1958+ }

1959+ childDelayed <- liftIO $ readIORef childDelayedRef

1960+ return $ Compose $ TraverseChild

1961+ { _traverseChild_result = result

1962+ , _traverseChild_mode = Left TraverseChildHydration

1963+ { _traverseChildHydration_delayed = do

1964+ placeholder <- createTextNode doc ("" :: Text)

1965+ insertAfterPreviousNode placeholder

1966+ childDelayed

1967+ pure placeholder

1968+ }

1969+ }

1970+ HydrationMode_Immediate -> do

1971+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

992− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

1972+ df <- createDocumentFragment doc

993− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1973+ placeholder <- createTextNode doc ("" :: Text)

994− { _immediateDomBuilderEnv_parent = toNode df

1974+ Node.appendChild_ df placeholder

995− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

1975+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv

1976+ { _hydrationDomBuilderEnv_parent = Left $ toNode df

1977+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

996− , _immediateDomBuilderEnv_commitAction = markReady childReadyState

1978+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState

997− }

1979+ }

998− u <- liftIO $ readIORef unreadyChildren

1980+ u <- liftIO $ readIORef unreadyChildren

999− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

1981+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

1000− return $ Compose (df, placeholder, childReadyState, result)

1982+ return $ Compose $ TraverseChild

1983+ { _traverseChild_result = result

1984+ , _traverseChild_mode = Right TraverseChildImmediate

1985+ { _traverseChildImmediate_fragment = df

1986+ , _traverseChildImmediate_placeholder = placeholder

1987+ , _traverseChildImmediate_childReadyState = childReadyState

1988+ }

1989+ }

1001

1990

1002−{-# INLINABLE drawChildUpdateInt #-}

1991+{-# SPECIALIZE drawChildUpdate

1003−drawChildUpdateInt :: (MonadIO m, MonadJSM m)

1992+ :: HydrationDomBuilderEnv Spider HydrationM

1004− => ImmediateDomBuilderEnv t

1993+ -> (IORef (ChildReadyState Int) -> JSM ())

1005− -> (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

1994+ -> HydrationDomBuilderT s Spider HydrationM (Identity a)

1006− -> ImmediateDomBuilderT t m v'

1995+ -> DomRenderHookT Spider HydrationM (Compose (TraverseChild Spider HydrationM Int) Identity a)

1007− -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')

1996+ #-}

1008−drawChildUpdateInt initialEnv markReady child = do

1997+

1009− childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing

1998+{-# SPECIALIZE drawChildUpdate

1010− unreadyChildren <- liftIO $ newIORef 0

1999+ :: HydrationDomBuilderEnv Spider HydrationM

1011− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

2000+ -> (IORef (ChildReadyState (Some k)) -> JSM ())

1012− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

2001+ -> HydrationDomBuilderT s Spider HydrationM (f a)

1013− { _immediateDomBuilderEnv_parent = toNode df

2002+ -> DomRenderHookT Spider HydrationM (Compose (TraverseChild Spider HydrationM (Some k)) f a)

1014− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

2003+ #-}

1015− , _immediateDomBuilderEnv_commitAction = markReady childReadyState

1016− }

1017− u <- liftIO $ readIORef unreadyChildren

1018− when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready

1019− return (df, placeholder, childReadyState, result)

1020

2004

2005+{-# INLINABLE drawChildUpdateInt #-}

2006+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)

2007+ => HydrationDomBuilderEnv t m

2008+ -> (IORef (ChildReadyState k) -> JSM ())

2009+ -> HydrationDomBuilderT s t m v

2010+ -> DomRenderHookT t m (TraverseChild t m k v)

2011+drawChildUpdateInt env mark m = fmap runIdentity . getCompose <$> drawChildUpdate env mark (Identity <$> m)

2012+

2013+{-# SPECIALIZE drawChildUpdateInt

2014+ :: HydrationDomBuilderEnv Spider HydrationM

2015+ -> (IORef (ChildReadyState k) -> JSM ())

2016+ -> HydrationDomBuilderT s Spider HydrationM v

2017+ -> DomRenderHookT Spider HydrationM (TraverseChild Spider HydrationM k v)

2018+ #-}

2019+

2020+{-# INLINE mkHasFocus #-}

2021+mkHasFocus

2022+ :: (HasDocument m, MonadJSM m, IsNode (RawElement d), MonadHold t m, Reflex t, DOM.IsDocumentOrShadowRoot (RawDocument (DomBuilderSpace m)))

1021−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

2023+ => Element er d t -> m (Dynamic t Bool)

1022mkHasFocus e = do

2024mkHasFocus e = do

1023− let initialFocus = False --TODO: Actually get the initial focus of the element

2025+ doc <- askDocument

2026+ initialFocus <- Node.isSameNode (toNode $ _element_raw e) . fmap toNode =<< Document.getActiveElement doc

1024 holdDyn initialFocus $ leftmost

2027 holdDyn initialFocus $ leftmost

1025 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

2028 [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

1026 , True <$ Reflex.select (_element_events e) (WrapArg Focus)

2029 , True <$ Reflex.select (_element_events e) (WrapArg Focus)

@@ -1029,39 +2032,49 @@ mkHasFocus e = do

1029insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()

2032insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()

1030insertBefore new existing = do

2033insertBefore new existing = do

1031 p <- getParentNodeUnchecked existing

2034 p <- getParentNodeUnchecked existing

1032− 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

2035+ Node.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

2036+

2037+type ImmediateDomBuilderT = HydrationDomBuilderT GhcjsDomSpace

1033

2038

1034−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

2039+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where

1035− type Performable (ImmediateDomBuilderT t m) = Performable m

2040+ type Performable (HydrationDomBuilderT s t m) = Performable m

1036 {-# INLINABLE performEvent_ #-}

2041 {-# INLINABLE performEvent_ #-}

1037 performEvent_ e = lift $ performEvent_ e

2042 performEvent_ e = lift $ performEvent_ e

1038 {-# INLINABLE performEvent #-}

2043 {-# INLINABLE performEvent #-}

1039 performEvent e = lift $ performEvent e

2044 performEvent e = lift $ performEvent e

1040

2045

1041−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where

2046+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where

1042 {-# INLINABLE getPostBuild #-}

2047 {-# INLINABLE getPostBuild #-}

1043 getPostBuild = lift getPostBuild

2048 getPostBuild = lift getPostBuild

1044

2049

1045−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where

2050+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where

1046 {-# INLINABLE newEventWithTrigger #-}

2051 {-# INLINABLE newEventWithTrigger #-}

1047 newEventWithTrigger = lift . newEventWithTrigger

2052 newEventWithTrigger = lift . newEventWithTrigger

1048 {-# INLINABLE newFanEventWithTrigger #-}

2053 {-# INLINABLE newFanEventWithTrigger #-}

1049 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

2054 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

1050

2055

1051−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (ImmediateDomBuilderT t m) where

2056+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (HydrationDomBuilderT s t m) where

2057+ {-# INLINABLE newTriggerEvent #-}

2058+ newTriggerEvent = HydrationDomBuilderT . lift $ newTriggerEvent

2059+ {-# INLINABLE newTriggerEventWithOnComplete #-}

2060+ newTriggerEventWithOnComplete = HydrationDomBuilderT . lift $ newTriggerEventWithOnComplete

2061+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

2062+ newEventWithLazyTriggerWithOnComplete f = HydrationDomBuilderT . lift $ newEventWithLazyTriggerWithOnComplete f

2063+

2064+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (DomRenderHookT t m) where

1052 {-# INLINABLE newTriggerEvent #-}

2065 {-# INLINABLE newTriggerEvent #-}

1053− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent

2066+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent

1054 {-# INLINABLE newTriggerEventWithOnComplete #-}

2067 {-# INLINABLE newTriggerEventWithOnComplete #-}

1055− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete

2068+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete

1056 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

2069 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

1057− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f

2070+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f

1058

2071

1059−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where

2072+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where

1060− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m

2073+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m

1061 askJSContext = lift askJSContext

2074 askJSContext = lift askJSContext

1062

2075

1063−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where

2076+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where

1064− type Ref (ImmediateDomBuilderT t m) = Ref m

2077+ type Ref (HydrationDomBuilderT s t m) = Ref m

1065 {-# INLINABLE newRef #-}

2078 {-# INLINABLE newRef #-}

1066 newRef = lift . newRef

2079 newRef = lift . newRef

1067 {-# INLINABLE readRef #-}

2080 {-# INLINABLE readRef #-}

@@ -1069,12 +2082,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where

1069 {-# INLINABLE writeRef #-}

2082 {-# INLINABLE writeRef #-}

1070 writeRef r = lift . writeRef r

2083 writeRef r = lift . writeRef r

1071

2084

1072−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where

2085+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where

1073 {-# INLINABLE atomicModifyRef #-}

2086 {-# INLINABLE atomicModifyRef #-}

1074 atomicModifyRef r = lift . atomicModifyRef r

2087 atomicModifyRef r = lift . atomicModifyRef r

1075

2088

1076−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where

2089+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where

1077− type JSX (ImmediateDomBuilderT t m) = JSX m

2090+ type JSX (HydrationDomBuilderT s t m) = JSX m

1078 liftJS = lift . liftJS

2091 liftJS = lift . liftJS

1079

2092

1080type family EventType en where

2093type family EventType en where

@@ -1532,11 +2545,11 @@ getTouchEvent = do

1532 , _touchEventResult_touches = touches

2545 , _touchEventResult_touches = touches

1533 }

2546 }

1534

2547

1535−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where

2548+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where

1536 {-# INLINABLE sample #-}

2549 {-# INLINABLE sample #-}

1537 sample = lift . sample

2550 sample = lift . sample

1538

2551

1539−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where

2552+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where

1540 {-# INLINABLE hold #-}

2553 {-# INLINABLE hold #-}

1541 hold v0 v' = lift $ hold v0 v'

2554 hold v0 v' = lift $ hold v0 v'

1542 {-# INLINABLE holdDyn #-}

2555 {-# INLINABLE holdDyn #-}

@@ -1558,7 +2571,7 @@ data Window t = Window

1558 , _window_raw :: DOM.Window

2571 , _window_raw :: DOM.Window

1559 }

2572 }

1560

2573

1561−wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)

2574+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> HydrationDomBuilderT GhcjsDomSpace t m (Window t)

1562wrapWindow wv _ = do

2575wrapWindow wv _ = do

1563 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName

2576 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName

1564 return $ Window

2577 return $ Window

reflex-dom-core/src/Reflex/Dom/Core.hs−1

@@ -2,7 +2,6 @@ module Reflex.Dom.Core (module X) where

3import Reflex as X hiding (askEvents)

4import Reflex.Dom.Builder.Class as X

5−import Reflex.Dom.Builder.Hydration as X hiding (askEvents, makeElement, ChildReadyState, drawChildUpdate, append, wrap, traverseIntMapWithKeyWithAdjust', hoistTraverseIntMapWithKeyWithAdjust)

6import Reflex.Dom.Builder.Immediate as X

5import Reflex.Dom.Builder.Immediate as X

7import Reflex.Dom.Builder.InputDisabled as X

6import Reflex.Dom.Builder.InputDisabled as X

8import Reflex.Dom.Builder.Static as X

7import Reflex.Dom.Builder.Static as X

reflex-dom-core/src/Reflex/Dom/Main.hs+33−72

@@ -20,7 +20,6 @@ import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)

20import Reflex.Adjustable.Class

21import Reflex.Class

22import Reflex.Dom.Builder.Immediate

23−import Reflex.Dom.Builder.Hydration

24import Reflex.Dom.Class

23import Reflex.Dom.Class

25import Reflex.Host.Class

24import Reflex.Host.Class

26import Reflex.PerformEvent.Base

25import Reflex.PerformEvent.Base

@@ -30,8 +29,6 @@ import Reflex.TriggerEvent.Base

30import Reflex.TriggerEvent.Class

29import Reflex.TriggerEvent.Class

31import qualified Reflex.TriggerEvent.Base as TriggerEvent

30import qualified Reflex.TriggerEvent.Base as TriggerEvent

33−import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported

34−

35import Control.Concurrent

32import Control.Concurrent

36import Control.Lens

33import Control.Lens

37import Control.Monad

34import Control.Monad

@@ -58,14 +55,14 @@ import qualified GHCJS.DOM.Types as DOM

58import Reflex.Profiled

55import Reflex.Profiled

59#endif

56#endif

61−{-# INLINE mainHydrationWidget #-}

58+{-# INLINE mainHydrationWidgetWithHead #-}

62−mainHydrationWidget :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

59+mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

63−mainHydrationWidget = mainHydrationWidget'

60+mainHydrationWidgetWithHead = mainHydrationWidgetWithHead'

65−{-# INLINABLE mainHydrationWidget' #-}

62+{-# INLINABLE mainHydrationWidgetWithHead' #-}

66−-- | Warning: `mainHydrationWidget'` is provided only as performance tweak. It is expected to disappear in future releases.

63+-- | Warning: `mainHydrationWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.

67−mainHydrationWidget' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()

64+mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()

68−mainHydrationWidget' = mainHydrationWidgetWithSwitchoverAction' (pure ())

65+mainHydrationWidgetWithHead' = mainHydrationWidgetWithSwitchoverAction' (pure ())

70{-# INLINE mainHydrationWidgetWithSwitchoverAction #-}

67{-# INLINE mainHydrationWidgetWithSwitchoverAction #-}

71mainHydrationWidgetWithSwitchoverAction :: IO () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

68mainHydrationWidgetWithSwitchoverAction :: IO () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

@@ -83,7 +80,7 @@ mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do

83attachHydrationWidget

80attachHydrationWidget

84 :: IO ()

81 :: IO ()

85 -> IORef HydrationMode

82 -> IORef HydrationMode

86− -> IORef [(Node, HydrationRunnerT DomTimeline (PostBuildT DomTimeline (WithJSContextSingleton () (PerformEventT DomTimeline DomHost))) ())]

83+ -> IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())]

87 -> JSContextSingleton ()

84 -> JSContextSingleton ()

88 -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ()))))

85 -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ()))))

89 -> IO (a, FireCommand DomTimeline DomHost)

86 -> IO (a, FireCommand DomTimeline DomHost)

@@ -106,7 +103,7 @@ attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do

106 liftIO $ switchoverAction

103 liftIO $ switchoverAction

107 pure (result, fc)

104 pure (result, fc)

108

105

109−type HydrationWidget x a = HydrationDomBuilderT DomTimeline (DomCoreWidget x) a

106+type HydrationWidget x a = HydrationDomBuilderT HydrationDomSpace DomTimeline (DomCoreWidget x) a

110

107

111-- | A widget that isn't attached to any particular part of the DOM hierarchy

108-- | A widget that isn't attached to any particular part of the DOM hierarchy

112type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)

109type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)

@@ -152,52 +149,6 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM

152 return (events, postBuildTriggerRef)

149 return (events, postBuildTriggerRef)

153 liftIO $ processAsyncEvents events fc

150 liftIO $ processAsyncEvents events fc

154

151

155−{-# INLINABLE mainHydrationWidgetWithHeadImmediate #-}

156−mainHydrationWidgetWithHeadImmediate :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

157−mainHydrationWidgetWithHeadImmediate = mainHydrationWidgetWithHeadImmediate'

158−

159−{-# INLINABLE mainHydrationWidgetWithHeadImmediate' #-}

160−-- | Warning: `mainHydrationWidgetWithHeadImmediate'` is provided only as performance tweak. It is expected to disappear in future releases.

161−mainHydrationWidgetWithHeadImmediate' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()

162−mainHydrationWidgetWithHeadImmediate' head' body = do

163− runHydrationWidgetWithHeadAndBodyImmediate $ \appendHead appendBody -> do

164− appendHead head'

165− appendBody body

166−

167−{-# INLINABLE runHydrationWidgetWithHeadAndBodyImmediate #-}

168−runHydrationWidgetWithHeadAndBodyImmediate

169− :: ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"

170− -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body"

171− -> FloatingWidget () ()

172− )

173− -> JSM ()

174−runHydrationWidgetWithHeadAndBodyImmediate app = withJSContextSingletonMono $ \jsSing -> do

175− globalDoc <- currentDocumentUnchecked

176− headElement <- getHeadUnchecked globalDoc

177− bodyElement <- getBodyUnchecked globalDoc

178− unreadyChildren <- liftIO $ newIORef 0

179− hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

180− (events, fc) <- liftIO . attachWidget'' $ \events -> do

181− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

182− let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c

183− hydrateDom n w = do

184− events' <- TriggerEvent.askEvents

185− delayed <- liftIO $ newIORef $ pure ()

186− lift $ do

187− let builderEnv = HydrationDomBuilderEnv

188− { _hydrationDomBuilderEnv_document = globalDoc

189− , _hydrationDomBuilderEnv_parent = Left $ toNode n

190− , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

191− , _hydrationDomBuilderEnv_commitAction = pure ()

192− , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

193− , _hydrationDomBuilderEnv_switchover = never

194− , _hydrationDomBuilderEnv_delayed = delayed

195− }

196− runHydrationDomBuilderT w builderEnv events'

197− runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing

198− return (events, postBuildTriggerRef)

199− liftIO $ processAsyncEvents events fc

200−

201{-# INLINE mainWidget #-}

152{-# INLINE mainWidget #-}

202mainWidget :: (forall x. Widget x ()) -> JSM ()

153mainWidget :: (forall x. Widget x ()) -> JSM ()

203mainWidget = mainWidget'

154mainWidget = mainWidget'

@@ -249,7 +200,7 @@ runDomHost = runSpiderHost

249 . runProfiledM

200 . runProfiledM

250#endif

201#endif

251

202

252−type Widget x = PostBuildT DomTimeline (ImmediateDomBuilderT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))) --TODO: Make this more abstract --TODO: Put the WithJSContext underneath PerformEventT - I think this would perform better because it could avoid fmapping over every performEvent

203+type Widget x = ImmediateDomBuilderT DomTimeline (DomCoreWidget x)

253

204

254{-# INLINABLE attachWidget #-}

205{-# INLINABLE attachWidget #-}

255attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

206attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

@@ -263,19 +214,24 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do

263 headFragment <- createDocumentFragment doc

214 headFragment <- createDocumentFragment doc

264 bodyElement <- getBodyUnchecked doc

215 bodyElement <- getBodyUnchecked doc

265 bodyFragment <- createDocumentFragment doc

216 bodyFragment <- createDocumentFragment doc

217+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

266 (events, fc) <- liftIO . attachWidget'' $ \events -> do

218 (events, fc) <- liftIO . attachWidget'' $ \events -> do

267 let (headWidget, bodyWidget) = widgets

219 let (headWidget, bodyWidget) = widgets

268 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

220 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

269 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c

221 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c

270 go w df = do

222 go w df = do

271 unreadyChildren <- liftIO $ newIORef 0

223 unreadyChildren <- liftIO $ newIORef 0

272− let builderEnv = ImmediateDomBuilderEnv

224+ delayed <- liftIO $ newIORef $ pure ()

273− { _immediateDomBuilderEnv_document = toDocument doc

225+ let builderEnv = HydrationDomBuilderEnv

274− , _immediateDomBuilderEnv_parent = toNode df

226+ { _hydrationDomBuilderEnv_document = toDocument doc

275− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

227+ , _hydrationDomBuilderEnv_parent = Left $ toNode df

276− , _immediateDomBuilderEnv_commitAction = return () --TODO

228+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

229+ , _hydrationDomBuilderEnv_commitAction = return () --TODO

230+ , _hydrationDomBuilderEnv_switchover = never

231+ , _hydrationDomBuilderEnv_delayed = delayed

232+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

277 }

233 }

278− runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

234+ runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing

279 rec b <- go (headWidget a) headFragment

235 rec b <- go (headWidget a) headFragment

280 a <- go (bodyWidget b) bodyFragment

236 a <- go (bodyWidget b) bodyFragment

281 return (events, postBuildTriggerRef)

237 return (events, postBuildTriggerRef)

@@ -294,16 +250,21 @@ attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> J

294attachWidget' rootElement jsSing w = do

250attachWidget' rootElement jsSing w = do

295 doc <- getOwnerDocumentUnchecked rootElement

251 doc <- getOwnerDocumentUnchecked rootElement

296 df <- createDocumentFragment doc

252 df <- createDocumentFragment doc

253+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

297 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do

254 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do

298 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

255 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

299 unreadyChildren <- liftIO $ newIORef 0

256 unreadyChildren <- liftIO $ newIORef 0

300− let builderEnv = ImmediateDomBuilderEnv

257+ delayed <- liftIO $ newIORef $ pure ()

301− { _immediateDomBuilderEnv_document = toDocument doc

258+ let builderEnv = HydrationDomBuilderEnv

302− , _immediateDomBuilderEnv_parent = toNode df

259+ { _hydrationDomBuilderEnv_document = toDocument doc

303− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

260+ , _hydrationDomBuilderEnv_parent = Left $ toNode df

304− , _immediateDomBuilderEnv_commitAction = return () --TODO

261+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

262+ , _hydrationDomBuilderEnv_commitAction = return () --TODO

263+ , _hydrationDomBuilderEnv_switchover = never

264+ , _hydrationDomBuilderEnv_delayed = delayed

265+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

305 }

266 }

306− a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

267+ a <- runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing

307 return ((a, events), postBuildTriggerRef)

268 return ((a, events), postBuildTriggerRef)

308 replaceElementContents rootElement df

269 replaceElementContents rootElement df

309 liftIO $ processAsyncEvents events fc

270 liftIO $ processAsyncEvents events fc

@@ -353,7 +314,7 @@ runApp' app = withJSContextSingleton $ \jsSing -> do

353 body <- getBodyUnchecked doc

314 body <- getBodyUnchecked doc

354 win <- getDefaultViewUnchecked doc

315 win <- getDefaultViewUnchecked doc

355 rec o <- attachWidget body jsSing $ do

316 rec o <- attachWidget body jsSing $ do

356− w <- lift $ wrapWindow win $ _appOutput_windowConfig o

317+ w <- wrapWindow win $ _appOutput_windowConfig o

357 app $ AppInput

318 app $ AppInput

358 { _appInput_window = w

319 { _appInput_window = w

359 }

320 }

reflex-dom-core/src/Reflex/Dom/Prerender.hs+20−16

@@ -38,8 +38,7 @@ import GHCJS.DOM.Types (MonadJSM)

38import Reflex hiding (askEvents)

39import Reflex.Dom.Builder.Class

40import Reflex.Dom.Builder.InputDisabled

41−import Reflex.Dom.Builder.Immediate (ImmediateDomBuilderT, insertBefore, deleteBetweenExclusive, runImmediateDomBuilderT, ImmediateDomBuilderEnv(..), GhcjsDomSpace)

41+import Reflex.Dom.Builder.Immediate

42−import Reflex.Dom.Builder.Hydration

43import Reflex.Dom.Builder.Static

42import Reflex.Dom.Builder.Static

44import Reflex.Host.Class

43import Reflex.Host.Class

@@ -93,14 +92,14 @@ class Prerender t m | m -> t where

93 -- hydration will fail.

92 -- hydration will fail.

94 prerenderImpl :: m (a, b) -> ((PrerenderClientConstraint t (Client m)) => Client m b) -> m (Maybe a, Dynamic t b)

93 prerenderImpl :: m (a, b) -> ((PrerenderClientConstraint t (Client m)) => Client m b) -> m (Maybe a, Dynamic t b)

96−instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (ImmediateDomBuilderT t m) where

95+instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (HydrationDomBuilderT GhcjsDomSpace t m) where

97− type Client (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m

96+ type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m

98 prerenderImpl _ client = (,) Nothing . pure <$> client

97 prerenderImpl _ client = (,) Nothing . pure <$> client

100−instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT t m) where

99+instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT HydrationDomSpace t m) where

101− -- | PostBuildT is needed here because we delay running the immediate builder

100+ -- | PostBuildT is needed here because we delay running the client builder

102 -- until after switchover, at which point the postBuild of @m@ has already fired

101 -- until after switchover, at which point the postBuild of @m@ has already fired

103− type Client (HydrationDomBuilderT t m) = PostBuildT t (ImmediateDomBuilderT t m)

102+ type Client (HydrationDomBuilderT HydrationDomSpace t m) = PostBuildT t (HydrationDomBuilderT GhcjsDomSpace t m) -- PostBuildT t (ImmediateDomBuilderT t m)

104 -- | Runs the server widget up until switchover, then replaces it with the

103 -- | Runs the server widget up until switchover, then replaces it with the

105 -- client widget.

104 -- client widget.

106 prerenderImpl server client = do

105 prerenderImpl server client = do

@@ -109,25 +108,30 @@ instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerend

109 doc <- askDocument

108 doc <- askDocument

110 df <- Document.createDocumentFragment doc

109 df <- Document.createDocumentFragment doc

111 unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren

110 unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren

112− let immediateEnv = ImmediateDomBuilderEnv

111+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

113− { _immediateDomBuilderEnv_document = doc

114− , _immediateDomBuilderEnv_parent = DOM.toNode df

115− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

116− , _immediateDomBuilderEnv_commitAction = pure ()

117− }

118 delayed <- liftIO $ newIORef $ pure ()

112 delayed <- liftIO $ newIORef $ pure ()

113+ let env' = HydrationDomBuilderEnv

114+ { _hydrationDomBuilderEnv_document = doc

115+ , _hydrationDomBuilderEnv_parent = Left $ DOM.toNode df

116+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

117+ , _hydrationDomBuilderEnv_commitAction = pure ()

118+ , _hydrationDomBuilderEnv_delayed = delayed

119+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

120+ , _hydrationDomBuilderEnv_switchover = never

121+ }

119 (a, b0) <- lift $ runHydrationDomBuilderT server (env { _hydrationDomBuilderEnv_delayed = delayed }) events

122 (a, b0) <- lift $ runHydrationDomBuilderT server (env { _hydrationDomBuilderEnv_delayed = delayed }) events

120 (b', trigger) <- newTriggerEvent

123 (b', trigger) <- newTriggerEvent

121 getHydrationMode >>= \case

124 getHydrationMode >>= \case

122 HydrationMode_Immediate -> do

125 HydrationMode_Immediate -> do

123− liftIO . trigger <=< lift $ runImmediateDomBuilderT (runPostBuildT client $ void b') immediateEnv events

126+ liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void b') env' events

127+ append $ DOM.toNode df

124 HydrationMode_Hydrating -> addHydrationStep $ do

128 HydrationMode_Hydrating -> addHydrationStep $ do

125− liftIO . trigger <=< lift $ runImmediateDomBuilderT (runPostBuildT client $ void b') immediateEnv events

129+ liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void b') env' events

126 insertBefore df =<< deleteToPrerenderEnd

130 insertBefore df =<< deleteToPrerenderEnd

127 (,) (Just a) <$> holdDyn b0 b'

131 (,) (Just a) <$> holdDyn b0 b'

128

132

129instance SupportsStaticDomBuilder t m => Prerender t (StaticDomBuilderT t m) where

133instance SupportsStaticDomBuilder t m => Prerender t (StaticDomBuilderT t m) where

130− type Client (StaticDomBuilderT t m) = ImmediateDomBuilderT t m

134+ type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m

131 prerenderImpl server _ = do

135 prerenderImpl server _ = do

132 _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()

136 _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()

133 (a, b) <- server

137 (a, b) <- server

reflex-dom-core/src/Reflex/Dom/Specializations.hsdeleted−175

@@ -1,175 +0,0 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE PolyKinds #-}

4−{-# LANGUAGE Rank2Types #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−module Reflex.Dom.Specializations () where

7−

8−import Control.Concurrent.Chan (Chan)

9−import Data.Dependent.Sum (DSum)

10−import Data.Dependent.Map (DMap)

11−import Data.Some (Some)

12−import Data.Text (Text)

13−import Reflex.Spider

14−import Reflex.Class

15−import Foreign.JavaScript.TH

16−import Reflex.PerformEvent.Base

17−import Reflex.PostBuild.Base

18−import Reflex.Requester.Base

19−import Reflex.TriggerEvent.Base

20−import Reflex.Dom.Builder.Class

21−import Reflex.Dom.Builder.Immediate

22−import qualified Reflex.Dom.Builder.Hydration as H

23−import Data.Functor.Identity

24−import Data.Functor.Compose

25−import Data.IORef

26−import GHCJS.DOM.Types (JSM)

27−import Data.IntMap.Strict (IntMap)

28−import qualified Data.IntMap.Strict as IntMap

29−

30−import qualified GHCJS.DOM.Element as DOM

31−import qualified GHCJS.DOM.Types as DOM

32−

33−{-# SPECIALIZE makeElement :: forall er a. Text -> ElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) ((Element er GhcjsDomSpace (SpiderTimeline Global), a), DOM.Element) #-}

34−

35−{-# SPECIALIZE wrap :: forall er. RawElement GhcjsDomSpace -> RawElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (Element er GhcjsDomSpace (SpiderTimeline Global)) #-}

36−

37−{-# SPECIALIZE mapIntMapWithAdjustImpl :: forall v v'.

38− ( (IntMap.Key -> (Event (SpiderTimeline Global) (), v) -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')

39− -> IntMap (Event (SpiderTimeline Global) (), v)

40− -> Event (SpiderTimeline Global) (PatchIntMap (Event (SpiderTimeline Global) (), v))

41− -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))

42− )

43− -> (IntMap.Key -> v -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')

44− -> IntMap v

45− -> Event (SpiderTimeline Global) (PatchIntMap v)

46− -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))

47− #-}

48−

49−{-# SPECIALIZE append :: DOM.Node -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) () #-}

50−

51−{-# SPECIALIZE drawChildUpdate :: forall k v' a. ImmediateDomBuilderEnv (SpiderTimeline Global) -> (IORef (ChildReadyState k) -> JSM ()) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a) -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a) #-}

52−

53−{-# SPECIALIZE traverseIntMapWithKeyWithAdjust' :: forall v v'. (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v') -> IntMap v -> Event (SpiderTimeline Global) (PatchIntMap v) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) #-}

54−

55−{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust :: forall v v'.

56− ( (IntMap.Key -> v -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

57− -> IntMap v

58− -> Event (SpiderTimeline Global) (PatchIntMap v)

59− -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event (SpiderTimeline Global) (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))

60− )

61− -> (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt)))

62− -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ())

63− -> (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v')

64− -> IntMap v

65− -> Event (SpiderTimeline Global) (PatchIntMap v)

66− -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))

67− #-}

68−

69−-- Hydration stuff

70−

71−type HydrationM = WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))

72−

73−{-# SPECIALIZE H.makeElement

74− :: Text

75− -> ElementConfig er Spider H.HydrationDomSpace

76− -> H.HydrationDomBuilderT Spider HydrationM a

77− -> H.HydrationDomBuilderT Spider HydrationM

78− ((Element er H.HydrationDomSpace Spider, a), Either DOM.Element (IORef DOM.Element))

79− #-}

80−

81−{-# SPECIALIZE H.makeNodeInternal

82− :: H.HydrationDomBuilderT Spider HydrationM DOM.Element

83− -> H.HydrationDomBuilderT Spider HydrationM DOM.Element

84− #-}

85−{-# SPECIALIZE H.makeNodeInternal

86− :: H.HydrationDomBuilderT Spider HydrationM DOM.Text

87− -> H.HydrationDomBuilderT Spider HydrationM DOM.Text

88− #-}

89−

90−{-# SPECIALIZE H.makeNodeInternal

91− :: H.HydrationDomBuilderT Spider HydrationM DOM.Comment

92− -> H.HydrationDomBuilderT Spider HydrationM DOM.Comment

93− #-}

94−

95−{-# SPECIALIZE H.drawChildUpdate

96− :: H.HydrationDomBuilderEnv Spider HydrationM

97− -> (IORef (H.ChildReadyState Int) -> JSM ())

98− -> H.HydrationDomBuilderT Spider HydrationM (Identity a)

99− -> H.DomRenderHookT Spider HydrationM (Compose (H.TraverseChild Spider HydrationM Int) Identity a)

100− #-}

101−

102−{-# SPECIALIZE H.drawChildUpdate

103− :: H.HydrationDomBuilderEnv Spider HydrationM

104− -> (IORef (H.ChildReadyState (Some k)) -> JSM ())

105− -> H.HydrationDomBuilderT Spider HydrationM (f a)

106− -> H.DomRenderHookT Spider HydrationM (Compose (H.TraverseChild Spider HydrationM (Some k)) f a)

107− #-}

108−

109−{-# SPECIALIZE H.drawChildUpdateInt

110− :: H.HydrationDomBuilderEnv Spider HydrationM

111− -> (IORef (H.ChildReadyState k) -> JSM ())

112− -> H.HydrationDomBuilderT Spider HydrationM v

113− -> H.DomRenderHookT Spider HydrationM (H.TraverseChild Spider HydrationM k v)

114− #-}

115−

116−{-# SPECIALIZE H.append

117− :: DOM.Node

118− -> H.HydrationDomBuilderT Spider HydrationM ()

119− #-}

120−

121−{-# SPECIALIZE H.wrap

122− :: Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

123− -> DOM.Element

124− -> RawElementConfig er Spider H.HydrationDomSpace

125− -> H.HydrationDomBuilderT Spider HydrationM (DMap EventName (EventFilterTriggerRef Spider er))

126− #-}

127−

128−{-# SPECIALIZE H.triggerBody

129− :: DOM.JSContextRef

130− -> ElementConfig er Spider H.HydrationDomSpace

131− -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

132− -> DMap EventName (EventFilterTriggerRef Spider er)

133− -> DOM.Element

134− -> H.WrapArg er EventName x

135− -> H.EventTrigger Spider x

136− -> IO (IO ())

137− #-}

138−

139−{-# SPECIALIZE H.traverseIntMapWithKeyWithAdjust'

140− :: (IntMap.Key -> v -> H.HydrationDomBuilderT Spider HydrationM v')

141− -> IntMap v

142− -> Event Spider (PatchIntMap v)

143− -> H.HydrationDomBuilderT Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

144− #-}

145−

146−{-# SPECIALIZE H.hoistTraverseIntMapWithKeyWithAdjust

147− :: ((IntMap.Key -> v -> H.DomRenderHookT Spider HydrationM (H.TraverseChild Spider HydrationM Int v'))

148− -> IntMap v

149− -> Event Spider (PatchIntMap v)

150− -> H.DomRenderHookT Spider HydrationM (IntMap (H.TraverseChild Spider HydrationM Int v'), Event Spider (PatchIntMap (H.TraverseChild Spider HydrationM Int v'))))

151− -> (PatchIntMap (H.TraverseChild Spider HydrationM Int v')

152− -> IntMap (IORef (H.ChildReadyState Int))

153− -> IO (IntMap (IORef (H.ChildReadyState Int))))

154− -> (IORef (IntMap DOM.Text)

155− -> DOM.Text

156− -> PatchIntMap (H.TraverseChild Spider HydrationM Int v')

157− -> JSM ())

158− -> (IntMap.Key -> v -> H.HydrationDomBuilderT Spider HydrationM v')

159− -> IntMap v

160− -> Event Spider (PatchIntMap v)

161− -> H.HydrationDomBuilderT Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

162− #-}

163−

164−{-# SPECIALIZE H.runHydrationDomBuilderT

165− :: H.HydrationDomBuilderT Spider HydrationM a

166− -> H.HydrationDomBuilderEnv Spider HydrationM

167− -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

168− -> HydrationM a

169− #-}

170−

171−{-# SPECIALIZE H.runDomRenderHookT

172− :: H.DomRenderHookT Spider HydrationM a

173− -> Chan [DSum (EventTriggerRef Spider) TriggerInvocation]

174− -> HydrationM a

175− #-}

reflex-dom-core/test/hydration.hs−1

@@ -42,7 +42,6 @@ import Network.HTTP.Types (status200)

42import Network.Socket

43import Network.Wai

44import Network.WebSockets

45−import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)

46import Reflex.Dom.Core

45import Reflex.Dom.Core

47import Reflex.Patch.DMapWithMove

46import Reflex.Patch.DMapWithMove

48import System.Directory

47import System.Directory

reflex-dom/benchmarks/krausest.hs+1−2

@@ -26,8 +26,7 @@ type TableDiff = PatchIntMap Row

26main :: IO ()

27main = do

28 seed <- randomIO

29−-- mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed) -- Immediate builder

29+ mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed)

30− mainHydrationWidgetWithHeadImmediate' headW (bodyW seed) -- Hydration builder

32titleW :: DomBuilder t m => m ()

31titleW :: DomBuilder t m => m ()

33titleW = text "Reflex-dom keyed"

32titleW = text "Reflex-dom keyed"

reflex-dom/src/Reflex/Dom.hs+2−1

@@ -2,5 +2,6 @@ module Reflex.Dom (module X) where

3import Foreign.JavaScript.Orphans ()

4import Reflex.Dom.Core as X hiding (mainWidget, mainWidgetInElementById, mainWidgetWithCss,

5− mainWidgetWithHead, mainWidgetWithHead', runApp', mainHydrationWidgetWithHeadImmediate)

5+ mainWidgetWithHead, mainWidgetWithHead', runApp',

6+ mainHydrationWidgetWithHead, mainHydrationWidgetWithHead')

6import Reflex.Dom.Internal as X

7import Reflex.Dom.Internal as X

reflex-dom/src/Reflex/Dom/Internal.hs+12−14

@@ -4,18 +4,24 @@

4{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE TypeFamilies #-}

6module Reflex.Dom.Internal

7+ ( module Main

8+ , run

9+ , mainWidget

7− (module Main, run, mainWidget, mainWidgetWithHead, mainWidgetWithCss,

10+ , mainWidgetWithHead, mainWidgetWithCss, mainWidgetWithHead', mainWidgetInElementById, runApp'

8− mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHead, mainHydrationWidgetWithHead', mainHydrationWidgetWithHeadImmediate, mainHydrationWidgetWithHeadImmediate') where

11+ , mainHydrationWidgetWithHead, mainHydrationWidgetWithHead'

12+ ) where

10import Data.ByteString (ByteString)

14import Data.ByteString (ByteString)

11import Data.Text (Text)

15import Data.Text (Text)

12import Reflex.Dom.Core (Widget)

16import Reflex.Dom.Core (Widget)

13import Reflex.Dom.Main as Main hiding

17import Reflex.Dom.Main as Main hiding

14 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

18 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

15− mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)

19+ mainWidgetWithHead', mainWidgetInElementById, runApp',

20+ mainHydrationWidgetWithHead, mainHydrationWidgetWithHead')

16import qualified Reflex.Dom.Main as Main

21import qualified Reflex.Dom.Main as Main

17 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

22 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

18− mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)

23+ mainWidgetWithHead', mainWidgetInElementById, runApp',

24+ mainHydrationWidgetWithHead, mainHydrationWidgetWithHead')

20#if defined(ghcjs_HOST_OS)

26#if defined(ghcjs_HOST_OS)

21run :: a -> a

27run :: a -> a

@@ -103,17 +109,9 @@ runApp' app = run $ Main.runApp' app

103{-# INLINE runApp' #-}

109{-# INLINE runApp' #-}

104

110

105mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> IO ()

111mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> IO ()

106−mainHydrationWidgetWithHead h b = run $ Main.mainHydrationWidget h b

112+mainHydrationWidgetWithHead h b = run $ Main.mainHydrationWidgetWithHead h b

107{-# INLINE mainHydrationWidgetWithHead #-}

113{-# INLINE mainHydrationWidgetWithHead #-}

108

114

109mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> IO ()

115mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> IO ()

110−mainHydrationWidgetWithHead' h b = run $ Main.mainHydrationWidget' h b

116+mainHydrationWidgetWithHead' h b = run $ Main.mainHydrationWidgetWithHead' h b

111{-# INLINE mainHydrationWidgetWithHead' #-}

117{-# INLINE mainHydrationWidgetWithHead' #-}

112−

113−mainHydrationWidgetWithHeadImmediate :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> IO ()

114−mainHydrationWidgetWithHeadImmediate h b = run $ Main.mainHydrationWidgetWithHeadImmediate h b

115−{-# INLINE mainHydrationWidgetWithHeadImmediate #-}

116−

117−mainHydrationWidgetWithHeadImmediate' :: HydrationWidget () () -> HydrationWidget () () -> IO ()

118−mainHydrationWidgetWithHeadImmediate' h b = run $ Main.mainHydrationWidgetWithHeadImmediate' h b

119−{-# INLINE mainHydrationWidgetWithHeadImmediate' #-}