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

git.iko.soy/reflex-dom

Replace immediate builder with hydration builder

commit0a032a1115e70eeae15ee8352edbea1233331923 authorTom Smalley <tfsmalley@gmail.com> dateMon 14 Jan 2019, 13:24 (8 years ago) parentbd2a070

11 files changed+1643−2433

compare with develop

unifiedsplit

reflex-dom-core/reflex-dom-core.cabal−2 reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs−1587 reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+1575−562 reflex-dom-core/src/Reflex/Dom/Core.hs−1 reflex-dom-core/src/Reflex/Dom/Main.hs+33−72 reflex-dom-core/src/Reflex/Dom/Prerender.hs+20−16 reflex-dom-core/src/Reflex/Dom/Specializations.hs−175 reflex-dom-core/test/hydration.hs−1 reflex-dom/benchmarks/krausest.hs+1−2 reflex-dom/src/Reflex/Dom.hs+2−1 reflex-dom/src/Reflex/Dom/Internal.hs+12−14

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

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

9191 Foreign.JavaScript.Utils

9292 Reflex.Dom.Builder.Class

9393 Reflex.Dom.Builder.Class.Events

94− Reflex.Dom.Builder.Hydration

9594 Reflex.Dom.Builder.Immediate

9695 Reflex.Dom.Builder.InputDisabled

9796 Reflex.Dom.Builder.Static

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

103102 Reflex.Dom.Modals.Class

104103 Reflex.Dom.Old

105104 Reflex.Dom.Prerender

106− Reflex.Dom.Specializations

107105 Reflex.Dom.Time

108106 Reflex.Dom.WebSocket

109107 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 @@

22{-# LANGUAGE CPP #-}

33{-# LANGUAGE ConstraintKinds #-}

44{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE DefaultSignatures #-}

5+{-# LANGUAGE DeriveFunctor #-}

6+{-# LANGUAGE DeriveTraversable #-}

67{-# LANGUAGE EmptyDataDecls #-}

78{-# LANGUAGE FlexibleContexts #-}

89{-# LANGUAGE FlexibleInstances #-}

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

1112{-# LANGUAGE LambdaCase #-}

1213{-# LANGUAGE MultiParamTypeClasses #-}

1314{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE PatternGuards #-}

1416{-# LANGUAGE PolyKinds #-}

1517{-# LANGUAGE RankNTypes #-}

1618{-# LANGUAGE RecursiveDo #-}

1719{-# LANGUAGE ScopedTypeVariables #-}

18−{-# LANGUAGE StandaloneDeriving #-}

1920#ifdef USE_TEMPLATE_HASKELL

2021{-# LANGUAGE TemplateHaskell #-}

2122#endif

23+{-# LANGUAGE TupleSections #-}

2224{-# LANGUAGE TypeFamilies #-}

2325{-# LANGUAGE TypeOperators #-}

2426{-# LANGUAGE UndecidableInstances #-}

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

2628{-# LANGUAGE ForeignFunctionInterface #-}

2729{-# LANGUAGE JavaScriptFFI #-}

2830#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.

2947module Reflex.Dom.Builder.Immediate

30− ( EventTriggerRef (..)

31− , ImmediateDomBuilderEnv (..)

32− , ImmediateDomBuilderT (..)

33− , runImmediateDomBuilderT

34− , askParent

35− , askEvents

36− , append

37− , textNodeInternal

38− , deleteBetweenExclusive

39− , extractBetweenExclusive

40− , deleteUpTo

41− , extractUpTo

42− , SupportsImmediateDomBuilder

43− , collectUpTo

44− , collectUpToGivenParent

45− , EventFilterTriggerRef (..)

46− , wrap

47− , makeElement

48− , GhcjsDomHandler (..)

49− , GhcjsDomHandler1 (..)

50− , GhcjsDomEvent (..)

51− , GhcjsDomSpace

52− , GhcjsEventFilter (..)

53− , Pair1 (..)

54− , Maybe1 (..)

55− , GhcjsEventSpec (..)

56− , HasDocument (..)

57− , ghcjsEventSpec_filters

58− , ghcjsEventSpec_handler

59− , GhcjsEventHandler (..)

48+ ( HydrationDomBuilderT (..)

49+ , HydrationDomBuilderEnv (..)

50+ , HydrationMode (..)

51+ , HydrationRunnerT (..)

52+ , runHydrationRunnerT

53+ , ImmediateDomBuilderT

54+ , runHydrationDomBuilderT

55+

56+ , getHydrationMode

57+ , addHydrationStep

58+ , addHydrationStepWithSetup

59+ , setPreviousNode

60+

61+ , askParent

62+ , askEvents

63+ , append

64+ , textNodeInternal

65+ , deleteBetweenExclusive

66+ , extractBetweenExclusive

67+ , deleteUpTo

68+ , extractUpTo

69+ , SupportsHydrationDomBuilder

70+ , collectUpTo

71+ , collectUpToGivenParent

72+ , EventTriggerRef (..)

73+ , EventFilterTriggerRef (..)

74+ , wrap

75+ , elementInternal

76+ , hydrateNode

77+ , HydrationDomSpace

78+ , GhcjsDomSpace

79+ , GhcjsDomHandler (..)

80+ , GhcjsDomHandler1 (..)

81+ , GhcjsDomEvent (..)

82+ , GhcjsEventFilter (..)

83+ , Pair1 (..)

84+ , Maybe1 (..)

85+ , GhcjsEventSpec (..)

86+ , HasDocument (..)

87+ , ghcjsEventSpec_filters

88+ , ghcjsEventSpec_handler

89+ , GhcjsEventHandler (..)

6090#ifndef USE_TEMPLATE_HASKELL

61− , phantom2

91+ , phantom2

6292#endif

63− , drawChildUpdate

64− , ChildReadyState (..)

65− , ChildReadyStateInt (..)

66− , mkHasFocus

67− , insertBefore

68− , EventType

69− , defaultDomEventHandler

70− , defaultDomWindowEventHandler

71− , withIsEvent

72− , showEventName

73− , elementOnEventName

74− , windowOnEventName

75− , wrapDomEvent

76− , subscribeDomEvent

77− , wrapDomEventMaybe

78− , wrapDomEventsMaybe

79− , getKeyEvent

80− , getMouseEventCoords

81− , getTouchEvent

82− , WindowConfig (..)

83− , Window (..)

84− , wrapWindow

85− -- * Internal

86− , traverseDMapWithKeyWithAdjust'

87− , hoistTraverseWithKeyWithAdjust

88− , traverseIntMapWithKeyWithAdjust'

89− , hoistTraverseIntMapWithKeyWithAdjust

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

93+ , drawChildUpdate

94+ , ChildReadyState (..)

95+ , mkHasFocus

96+ , insertBefore

97+ , EventType

98+ , defaultDomEventHandler

99+ , defaultDomWindowEventHandler

100+ , withIsEvent

101+ , showEventName

102+ , elementOnEventName

103+ , windowOnEventName

104+ , wrapDomEvent

105+ , subscribeDomEvent

106+ , wrapDomEventMaybe

107+ , wrapDomEventsMaybe

108+ , getKeyEvent

109+ , getMouseEventCoords

110+ , getTouchEvent

111+ , WindowConfig (..)

112+ , Window (..)

113+ , wrapWindow

114+ -- * Internal

115+ , traverseDMapWithKeyWithAdjust'

116+ , hoistTraverseWithKeyWithAdjust

117+ , traverseIntMapWithKeyWithAdjust'

118+ , hoistTraverseIntMapWithKeyWithAdjust

119+ ) where

105120

106121import Control.Concurrent

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

122+import Control.Exception (bracketOnError)

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

108124import Control.Monad.Exception

109125import Control.Monad.Primitive

110126import Control.Monad.Reader

111127import Control.Monad.Ref

112−#ifndef USE_TEMPLATE_HASKELL

113−import Data.Functor.Contravariant (phantom)

114−#endif

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

115129import Data.Bitraversable

116130import Data.Default

117131import Data.Dependent.Map (DMap)

118−import qualified Data.Dependent.Map as DMap

119132import Data.Dependent.Sum

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

134+import Data.Foldable (for_)

120135import Data.Functor.Compose

121136import Data.Functor.Constant

122137import Data.Functor.Misc

123138import Data.Functor.Product

124139import Data.IORef

125−import qualified Data.Map as Map

140+import Data.IntMap.Strict (IntMap)

126141import Data.Maybe

127−import Data.Monoid hiding (Product)

128−import Data.Some (Some)

129−import qualified Data.Some as Some

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

130143import 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

132147import 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

134181import qualified GHCJS.DOM.Element as Element

135182import 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)

139183import qualified GHCJS.DOM.EventM as DOM

140184import qualified GHCJS.DOM.FileList as FileList

185+import qualified GHCJS.DOM.GlobalEventHandlers as Events

141186import qualified GHCJS.DOM.HTMLInputElement as Input

142187import qualified GHCJS.DOM.HTMLSelectElement as Select

143188import 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

145191import qualified GHCJS.DOM.Touch as Touch

146192import qualified GHCJS.DOM.TouchEvent as TouchEvent

147193import 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)

154194import qualified GHCJS.DOM.Types as DOM

155−import GHCJS.DOM.UIEvent

156−import GHCJS.DOM.KeyboardEvent as KeyboardEvent

157195import qualified GHCJS.DOM.Window as Window

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

159−import Data.IntMap.Strict (IntMap)

160−import qualified Data.IntMap.Strict as IntMap

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

162−import qualified Data.FastMutableIntMap as FastMutableIntMap

196+import qualified Reflex.Patch.DMap as PatchDMap

197+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

198+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

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

163200

164−import Reflex.Requester.Base

165−import Reflex.Requester.Class

166−import Foreign.JavaScript.Internal.Utils

201+#ifndef USE_TEMPLATE_HASKELL

202+import Data.Functor.Contravariant (phantom)

203+#endif

167204

168205#ifndef ghcjs_HOST_OS

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

170207

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

172− liftJSM' = ImmediateDomBuilderT . liftJSM'

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

218+ liftJSM' = lift . liftJSM'

173219#endif

174220

175−data ImmediateDomBuilderEnv t

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

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

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

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

180− }

221+data HydrationDomBuilderEnv t m = HydrationDomBuilderEnv

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

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)

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

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

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 ()))

235+ }

181236

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 }

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

184244#if MIN_VERSION_base(4,9,1)

185245 , MonadAsyncException

186246#endif

187247 )

188248

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

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

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

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

191251 primitive = lift . primitive

192252

193−instance MonadTrans (ImmediateDomBuilderT t) where

194− lift = ImmediateDomBuilderT . lift . lift . lift

253+instance MonadTrans (HydrationDomBuilderT s t) where

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

195269

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

197− withRenderHook hook (ImmediateDomBuilderT a) = do

198− e <- ImmediateDomBuilderT ask

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

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

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+

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

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

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

349+ DomRenderHookT $ withRequesting $ \rsp -> do

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

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

202− requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity

203− requestDomAction_ = ImmediateDomBuilderT . lift . requesting_

352+ requestDomAction = DomRenderHookT . requestingIdentity

353+ requestDomAction_ = DomRenderHookT . requesting_

204354

205−{-# INLINABLE runImmediateDomBuilderT #-}

206−runImmediateDomBuilderT

355+{-# INLINABLE runHydrationDomBuilderT #-}

356+runHydrationDomBuilderT

207357 :: ( MonadFix m

208358 , PerformEvent t m

209359 , MonadReflexCreateTrigger t m

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

212362 , MonadRef m

213363 , Ref m ~ IORef

214364 )

215− => ImmediateDomBuilderT t m a

216− -> ImmediateDomBuilderEnv t

365+ => HydrationDomBuilderT s t m a

366+ -> HydrationDomBuilderEnv t m

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

218368 -> m a

219−runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan =

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

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

229370

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

231372 {-# INLINABLE askDocument #-}

232− askDocument = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_document

373+ askDocument = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_document

233374

234375{-# INLINABLE askParent #-}

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

236−askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent

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

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)

237382

238383{-# INLINABLE askEvents #-}

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

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

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

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

241386

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

243−localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT

387+{-# INLINABLE localEnv #-}

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

244390

245391{-# INLINABLE append #-}

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

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

247393append n = do

248− p <- askParent

394+ p <- getParent

249395 liftJSM $ appendChild_ p n

250396 return ()

251397

252−{-# INLINABLE textNodeInternal #-}

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

254−textNodeInternal !t = do

255− doc <- askDocument

256− n <- liftJSM $ createTextNode doc t

398+{-# SPECIALIZE append

399+ :: DOM.Node

400+ -> HydrationDomBuilderT s Spider HydrationM ()

401+ #-}

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

257436 append $ toNode n

258437 return n

259438

260−{-# INLINABLE commentNodeInternal #-}

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

262−commentNodeInternal !t = do

263− doc <- askDocument

264− n <- liftJSM $ createComment doc t

265− append $ toNode n

439+{-# INLINE hydrateNode #-}

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

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

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

443+hydrateNode

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

266458 return n

267459

268460-- | 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

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

302494#endif

303495

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

305497

306498{-# INLINABLE collectUpTo #-}

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

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

319511

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

321513

322−{-# INLINABLE 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)

324−wrap e cfg = do

325− events <- askEvents

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

515+{-# INLINE wrap #-}

516+wrap

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

522+wrap events e cfg = do

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

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

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

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

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

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

341538 return $ en :=> EventFilterTriggerRef triggerRef

342− es <- do

343− let h :: GhcjsEventHandler er

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

345− ctx <- askJSM

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

347− case DMap.lookup en eventTriggerRefs of

348− Just (EventFilterTriggerRef r) -> do

349− writeIORef r $ Just t

350− return $ do

351− writeIORef r Nothing

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

353− evt <- DOM.event

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

355− case mv of

356− Nothing -> return ()

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

359− ref <- newIORef $ Just t

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

361− return $ Element

362− { _element_events = es

363− , _element_raw = e

364− }

365−

366−{-# INLINABLE makeElement #-}

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)

368−makeElement elementTag cfg child = do

369− doc <- askDocument

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

371− Nothing -> createElement doc elementTag

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

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

374− Nothing -> lift $ setAttribute e n v

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

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

377− { _immediateDomBuilderEnv_parent = toNode e

378− }

379− append $ toNode e

380− wrapped <- wrap e $ extractRawElementConfig cfg

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

539+ return eventTriggerRefs

540+

541+{-# SPECIALIZE wrap

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

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 ())

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

567+ Just (EventFilterTriggerRef r) -> do

568+ writeIORef r $ Just t

569+ return $ do

570+ writeIORef r Nothing

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

572+ evt <- DOM.event

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

574+ case mv of

575+ Nothing -> return ()

576+ Just v -> liftIO $ do

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

578+ ref <- newIORef $ Just t

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

580+ where

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

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

583+ handler :: GhcjsEventHandler er

584+ !handler = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg

585+

586+{-# SPECIALIZE triggerBody

587+ :: DOM.JSContextRef

588+ -> RawElementConfig er Spider HydrationDomSpace

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

590+ -> DMap EventName (EventFilterTriggerRef Spider er)

591+ -> DOM.Element

592+ -> WrapArg er EventName x

593+ -> EventTrigger Spider x

594+ -> IO (IO ())

595+ #-}

596+

597+{-# SPECIALIZE triggerBody

598+ :: DOM.JSContextRef

599+ -> RawElementConfig er Spider GhcjsDomSpace

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

382607

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

384609

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

446671 runReaderT (defaultDomEventHandler e en) evt

447672 }

448673

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

4501267 notReadyUntil e = do

4511268 eOnce <- headE e

452− env <- ImmediateDomBuilderT ask

453− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

1269+ unreadyChildren <- askUnreadyChildren

1270+ commitAction <- askCommitAction

4541271 liftIO $ modifyIORef' unreadyChildren succ

4551272 let ready = do

4561273 old <- liftIO $ readIORef unreadyChildren

4571274 let new = pred old

4581275 liftIO $ writeIORef unreadyChildren $! new

459− when (new == 0) $ _immediateDomBuilderEnv_commitAction env

1276+ when (new == 0) commitAction

4601277 requestDomAction_ $ ready <$ eOnce

4611278 notReady = do

462− env <- ImmediateDomBuilderT ask

463− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

1279+ unreadyChildren <- askUnreadyChildren

4641280 liftIO $ modifyIORef' unreadyChildren succ

4651281

466−instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where

467− type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace

1282+data HydrationDomSpace

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

4681311 {-# INLINABLE textNode #-}

469− textNode (TextNodeConfig initialContents mSetContents) = do

470− n <- textNodeInternal initialContents

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

472− return $ TextNode n

1312+ textNode = textNodeInternal

4731313 {-# INLINABLE commentNode #-}

474− commentNode (CommentNodeConfig initialContents mSetContents) = do

475− n <- commentNodeInternal initialContents

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

477− return $ CommentNode n

1314+ commentNode = commentNodeInternal

1315+ {-# INLINABLE inputElement #-}

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

4781326 {-# 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

4801332 {-# INLINABLE inputElement #-}

481− inputElement cfg = do

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

1333+ inputElement = inputElementImmediate

5321334 {-# INLINABLE textAreaElement #-}

533− textAreaElement cfg = do --TODO

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

1335+ textAreaElement = textAreaElementImmediate

5571336 {-# INLINABLE selectElement #-}

558− selectElement cfg child = do

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)

1337+ selectElement = selectElementImmediate

5831338 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

5851345

5861346data FragmentState

5871347 = FragmentState_Unmounted

@@ -601,21 +1361,21 @@ extractFragment fragment = do

6011361 extractBetweenExclusive (_immediateDomFragment_document fragment) before after

6021362 liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted

6031363

604−instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where

605− type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment

1364+instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomBuilderT GhcjsDomSpace t m) where

1365+ type DomFragment (HydrationDomBuilderT GhcjsDomSpace t m) = ImmediateDomFragment

6061366 buildDomFragment w = do

6071367 df <- createDocumentFragment =<< askDocument

6081368 result <- flip localEnv w $ \env -> env

609− { _immediateDomBuilderEnv_parent = toNode df

1369+ { _hydrationDomBuilderEnv_parent = Left $ toNode df

6101370 }

6111371 state <- liftIO $ newIORef FragmentState_Unmounted

6121372 return (ImmediateDomFragment df state, result)

6131373 mountDomFragment fragment setFragment = do

614− parent <- askParent

1374+ parent <- getParent

6151375 extractFragment fragment

616− before <- textNodeInternal ("" :: Text)

1376+ before <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

6171377 appendChild_ parent $ _immediateDomFragment_document fragment

618− after <- textNodeInternal ("" :: Text)

1378+ after <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing

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

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

6211381 extractFragment previousFragment

@@ -624,12 +1384,19 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB

6241384 liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

6251385 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

6261386

627−instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (ImmediateDomBuilderT t m) where

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+

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

6281394 {-# INLINABLE runWithReplace #-}

6291395 runWithReplace a0 a' = do

630− initialEnv <- ImmediateDomBuilderT ask

631− before <- textNodeInternal ("" :: Text)

632− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

1396+ initialEnv <- HydrationDomBuilderT ask

1397+ let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv

1398+ (hydrateStart, before, beforeKey) <- skipToReplaceStart

1399+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

6331400 haveEverBeenReady <- liftIO $ newIORef False

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

6351402 let myCommitAction = do

@@ -640,79 +1407,117 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

6401407 old <- liftIO $ readIORef parentUnreadyChildren

6411408 let new = pred old

6421409 liftIO $ writeIORef parentUnreadyChildren $! new

643− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

1410+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

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

6451412 doc <- askDocument

646− after <- createTextNode doc ("" :: Text)

1413+ parent <- getParent

1414+ (hydrateEnd, after) <- skipToReplaceEnd beforeKey

6471415 let drawInitialChild = do

1416+ h <- liftIO $ readIORef hydrating

1417+ p' <- case h of

1418+ HydrationMode_Hydrating -> pure parent

1419+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

6481420 unreadyChildren <- liftIO $ newIORef 0

649− let f = do

650− result <- a0

651− append $ toNode after

652− return result

653− result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv

654− { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

655− , _immediateDomBuilderEnv_commitAction = myCommitAction

1421+ let a0' = case h of

1422+ HydrationMode_Hydrating -> a0

1423+ HydrationMode_Immediate -> do

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

1430+ result <- runReaderT (unHydrationDomBuilderT a0') initialEnv

1431+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1432+ , _hydrationDomBuilderEnv_commitAction = myCommitAction

1433+ , _hydrationDomBuilderEnv_parent = Left p'

1434+ , _hydrationDomBuilderEnv_delayed = delayed

6561435 }

1436+ dom <- case h of

1437+ HydrationMode_Hydrating -> liftIO $ readIORef delayed

1438+ HydrationMode_Immediate -> pure $ pure ()

6571439 liftIO $ readIORef unreadyChildren >>= \case

6581440 0 -> writeIORef haveEverBeenReady True

6591441 _ -> modifyIORef' parentUnreadyChildren succ

660− return result

1442+ return (dom, result)

6611443 a'' <- numberOccurrences a'

662− (result0, child') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

663− df <- createDocumentFragment doc

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

1448+ HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

6641449 unreadyChildren <- liftIO $ newIORef 0

6651450 let commitAction = do

6661451 c <- liftIO $ readIORef currentCohort

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

668− deleteBetweenExclusive before after

669− insertBefore df after

1453+ !before' <- liftIO $ readIORef before

1454+ !after' <- liftIO $ readIORef after

1455+ deleteBetweenExclusive before' after'

1456+ insertBefore p' after'

6701457 liftIO $ writeIORef currentCohort cohortId

6711458 myCommitAction

672− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv

673− { _immediateDomBuilderEnv_parent = toNode df

674− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

675− , _immediateDomBuilderEnv_commitAction = commitAction

676− }

1459+ delayed <- case h of

1460+ HydrationMode_Hydrating -> liftIO $ newIORef $ pure ()

1461+ HydrationMode_Immediate -> pure $ _hydrationDomBuilderEnv_delayed initialEnv

1462+ result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv

1463+ { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1464+ , _hydrationDomBuilderEnv_commitAction = case h of

1465+ HydrationMode_Hydrating -> myCommitAction

1466+ HydrationMode_Immediate -> commitAction

1467+ , _hydrationDomBuilderEnv_parent = Left p'

1468+ , _hydrationDomBuilderEnv_delayed = delayed

1469+ }

1470+ dom <- case h of

1471+ HydrationMode_Hydrating -> liftIO $ readIORef delayed

1472+ HydrationMode_Immediate -> pure $ pure ()

6771473 uc <- liftIO $ readIORef unreadyChildren

6781474 let commitActionToRunNow = if uc == 0

679− then Just commitAction

1475+ then Just $ commitAction

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

681− return (commitActionToRunNow, result)

682− requestDomAction_ $ fmapMaybe fst child'

1477+ actions = case h of

1478+ HydrationMode_Hydrating -> Left dom

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

1486+ requestDomAction_ $ fmapMaybe id commitAction

6831487 return (result0, snd <$> child')

1488+

6841489 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

6851490 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'

6861491 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

6871492 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'

6881493 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

6891494 traverseDMapWithKeyWithAdjustWithMove = do

690− let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState 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)

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

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)

6921497 new k = PatchDMapWithMove.nodeInfoMapFromM $ \case

693− PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do

694− readIORef sRef >>= \case

1498+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Left _hydration) _)) -> return PatchDMapWithMove.From_Delete

1499+ PatchDMapWithMove.From_Insert (Compose (TraverseChild (Right immediate) _)) -> do

1500+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

6951501 ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete

6961502 ChildReadyState_Unready _ -> do

697− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

698− return $ PatchDMapWithMove.From_Insert $ Constant sRef

1503+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1504+ return $ PatchDMapWithMove.From_Insert $ Constant (_traverseChildImmediate_childReadyState immediate)

6991505 PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete

7001506 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)

7021508 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

7041510 return $ Constant ()

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

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

7071513 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

7091515 let p = unPatchDMapWithMove p_

7101516 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)

7131518 collectIfMoved k e = do

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

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

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

1520+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phsBefore

7161521 case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of

7171522 False -> do

7181523 mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

@@ -720,13 +1525,22 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

7201525 True -> do

7211526 Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder

7221527 collected <- DMap.traverseWithKey collectIfMoved p

723− let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this

724− let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)

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

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

7251538 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

7271540 case PatchDMapWithMove._nodeInfo_from e of

728− PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do

729− df `insertBefore` nextPlaceholder

1541+ PatchDMapWithMove.From_Insert (Compose (TraverseChild x _)) -> case x of

1542+ Left _ -> pure ()

1543+ Right immediate -> _traverseChildImmediate_fragment immediate `insertBefore` nextPlaceholder

7301544 PatchDMapWithMove.From_Delete -> do

7311545 return ()

7321546 PatchDMapWithMove.From_Move fromKey -> do

@@ -737,105 +1551,166 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

7371551 liftIO $ writeIORef placeholders $! phsAfter

7381552

7391553{-# INLINABLE 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'))

1554+traverseDMapWithKeyWithAdjust'

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'))

7411560traverseDMapWithKeyWithAdjust' = do

742− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState 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)

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

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

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

7451564 Nothing -> return Nothing

746− Just (Compose (_, _, sRef, _)) -> do

747− readIORef sRef >>= \case

1565+ Just (Compose (TraverseChild (Left _hydration) _)) -> pure Nothing

1566+ Just (Compose (TraverseChild (Right immediate) _)) -> do

1567+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

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

7491569 ChildReadyState_Unready _ -> do

750− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

751− return $ Just $ Constant sRef

1570+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1571+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)

7521572 delete _ (Constant sRef) = do

7531573 writeIORef sRef $ ChildReadyState_Unready Nothing

7541574 return $ Constant ()

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

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

7571577 return $ applyAlways p' old

758− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do

1578+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholder (PatchDMap patch) -> do

7591579 phs <- liftIO $ readIORef placeholders

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

761− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

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

763− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

764− forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder

765− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs

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

1581+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (This k) phs

1582+ -- Delete old node

1583+ forM_ (Map.lookup (This k) phs) $ \thisPlaceholder -> do

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

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

1597+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply filtered phs

7661598

7671599{-# 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'))

7691606traverseIntMapWithKeyWithAdjust' = do

770− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do

771− let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))

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

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

7721609 new k m = case m of

7731610 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

7751614 readIORef sRef >>= \case

776− ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready

777− ChildReadyStateInt_Unready _ -> do

778− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k

1615+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

1616+ ChildReadyState_Unready _ -> do

1617+ writeIORef sRef $ ChildReadyState_Unready $ Just k

7791618 return $ Just sRef

7801619 delete _ sRef = do

781− writeIORef sRef $ ChildReadyStateInt_Unready Nothing

1620+ writeIORef sRef $ ChildReadyState_Unready Nothing

7821621 return ()

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

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

7851624 return $ applyAlways p' old

786− hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do

1625+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholder (PatchIntMap p) -> do

7871626 phs <- liftIO $ readIORef placeholders

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

789− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

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

1629+ -- Delete old node

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

792− forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder

793− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs

1631+ -- Insert new node

1632+ forM_ mv $ \(TraverseChild e _) -> case e of

1633+ Left _hydration -> pure ()

1634+ Right immediate -> do

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

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

7941650

795−#if MIN_VERSION_base(4,9,0)

796−data ChildReadyState k

797−#else

798−data ChildReadyState (k :: * -> *)

799−#endif

1651+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust'

1652+ :: (IntMap.Key -> v -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM v')

1653+ -> IntMap v

1654+ -> Event Spider (PatchIntMap v)

1655+ -> HydrationDomBuilderT HydrationDomSpace Spider HydrationM (IntMap v', Event Spider (PatchIntMap v'))

1656+ #-}

1657+

1658+data ChildReadyState a

8001659 = ChildReadyState_Ready

801− | ChildReadyState_Unready !(Maybe (Some k))

1660+ | ChildReadyState_Unready !(Maybe a)

8021661 deriving (Show, Read, Eq, Ord)

8031662

804−data ChildReadyStateInt

805− = ChildReadyStateInt_Ready

806− | ChildReadyStateInt_Unready !(Maybe Int)

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

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

1664+insertAfterPreviousNode node = do

1665+ parent <- askParent

1666+ nextNode <- maybe (Node.getFirstChild parent) Node.getNextSibling =<< getPreviousNode

1667+ Node.insertBefore_ parent node nextNode

1668+ setPreviousNode $ Just $ toNode node

8081669

809−{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}

810−hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.

1670+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}

1671+hoistTraverseWithKeyWithAdjust

1672+ ::

8111673 ( Adjustable t m

1674+ , MonadHold t m

1675+ , DMap.GCompare k

8121676 , MonadIO m

8131677 , MonadJSM m

814− , MonadFix m

8151678 , PrimMonad m

816− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

817− , Functor p

1679+ , MonadFix m

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

8181687 )

819− => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

820− -> IntMap v

821− -> Event t (p v)

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')))

823− ) -- ^ The base monad's traversal

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

825− -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM

826− -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')

827− -> IntMap v

828− -> Event t (p v)

829− -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))

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

831− initialEnv <- ImmediateDomBuilderT ask

832− let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

833− pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty

1688+ => (forall vv vv'.

1689+ (forall a. k a -> vv a -> DomRenderHookT t m (vv' a))

1690+ -> DMap k vv

1691+ -> Event t (p k vv)

1692+ -> DomRenderHookT t m (DMap k vv', Event t (p k vv')))

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

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

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

1699+ -- ^ Apply a patch to the DOM

1700+ -> (forall a. k a -> v a -> HydrationDomBuilderT s t m (v' a))

1701+ -> DMap k v

1702+ -> Event t (p k v)

1703+ -> HydrationDomBuilderT s t m (DMap k v', Event t (p k v'))

1704+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

1705+ doc <- askDocument

1706+ initialEnv <- HydrationDomBuilderT ask

1707+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

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

8341709 haveEverBeenReady <- liftIO $ newIORef False

835− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"

836− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"

1710+ placeholders <- liftIO $ newIORef Map.empty

1711+ lastPlaceholder <- createTextNode doc ("" :: Text)

8371712 let applyDomUpdate p = do

838− applyDomUpdate_ placeholders lastPlaceholderRef p

1713+ applyDomUpdate_ placeholders lastPlaceholder p

8391714 markSelfReady

8401715 liftIO $ writeIORef pendingChange $! mempty

8411716 markSelfReady = do

@@ -846,86 +1721,105 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_

8461721 old <- liftIO $ readIORef parentUnreadyChildren

8471722 let new = pred old

8481723 liftIO $ writeIORef parentUnreadyChildren $! new

849− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

850− markChildReady :: IORef ChildReadyStateInt -> JSM ()

1724+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

1725+ markChildReady :: IORef (ChildReadyState (Some k)) -> JSM ()

8511726 markChildReady childReadyState = do

8521727 liftIO (readIORef childReadyState) >>= \case

853− ChildReadyStateInt_Ready -> return ()

854− ChildReadyStateInt_Unready countedAt -> do

855− liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready

1728+ ChildReadyState_Ready -> return ()

1729+ ChildReadyState_Unready countedAt -> do

1730+ liftIO $ writeIORef childReadyState ChildReadyState_Ready

8561731 case countedAt of

8571732 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

8591734 (oldUnready, p) <- liftIO $ readIORef pendingChange

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

861− let newUnready = IntMap.delete k oldUnready

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

1736+ let newUnready = DMap.delete k oldUnready

8621737 liftIO $ writeIORef pendingChange (newUnready, p)

863− when (IntMap.null newUnready) $ do

1738+ when (DMap.null newUnready) $ do

8641739 applyDomUpdate p

865− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

866− let processChild k (_, _, sRef, _) = do

867− readIORef sRef >>= \case

868− ChildReadyStateInt_Ready -> return Nothing

869− ChildReadyStateInt_Unready _ -> do

870− writeIORef sRef $ ChildReadyStateInt_Unready $ Just k

871− return $ Just sRef

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

873− liftIO $ if IntMap.null initialUnready

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

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

1742+ let processChild k (Compose (TraverseChild e _)) = case e of

1743+ Left _ -> pure $ ComposeMaybe Nothing

1744+ Right immediate -> ComposeMaybe <$> do

1745+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

1746+ ChildReadyState_Ready -> return Nothing

1747+ ChildReadyState_Unready _ -> do

1748+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just $ This k

1749+ return $ Just $ Constant (_traverseChildImmediate_childReadyState immediate)

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

1751+ liftIO $ if DMap.null initialUnready

8741752 then writeIORef haveEverBeenReady True

8751753 else do

8761754 modifyIORef' parentUnreadyChildren succ

8771755 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

879− placeholders0 = fmap (\(_, ph, _, _) -> ph) children0

880− result' = ffor children' $ fmap $ \(_, _, _, r) -> r

881− liftIO $ writeIORef placeholders $! placeholders0

882− _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0

883− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

1756+ getHydrationMode >>= \case

1757+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

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

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

1760+ liftIO $ writeIORef placeholders $! phs

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

8841769 requestDomAction_ $ ffor children' $ \p -> do

8851770 (oldUnready, oldP) <- liftIO $ readIORef pendingChange

8861771 newUnready <- liftIO $ updateChildUnreadiness p oldUnready

8871772 let !newP = p <> oldP

8881773 liftIO $ writeIORef pendingChange (newUnready, newP)

889− when (IntMap.null newUnready) $ do

1774+ when (DMap.null newUnready) $ do

8901775 applyDomUpdate newP

1776+ let result0 = DMap.map (_traverseChild_result . getCompose) children0

1777+ result' = ffor children' $ mapPatch $ _traverseChild_result . getCompose

8911778 return (result0, result')

8921779

893−{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}

894−hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

1780+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}

1781+hoistTraverseIntMapWithKeyWithAdjust ::

8951782 ( Adjustable t m

8961783 , MonadHold t m

897− , DMap.GCompare k

898− , MonadIO m

8991784 , MonadJSM m

900− , PrimMonad m

9011785 , MonadFix m

902− , Patch (p k v)

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

904− , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))

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

1786+ , PrimMonad m

1787+ , Monoid (p (TraverseChild t m Int v'))

1788+ , Functor p

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

9061794 )

907− => (forall vv vv'.

908− (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))

909− -> DMap k vv

910− -> Event t (p k vv)

911− -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))

912− ) -- ^ 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

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

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

916− -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))

917− -> DMap k v

918− -> Event t (p k v)

919− -> ImmediateDomBuilderT t m (DMap k v', Event t (p k 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

921− initialEnv <- ImmediateDomBuilderT ask

922− let parentUnreadyChildren = _immediateDomBuilderEnv_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

1795+ => ((IntMap.Key -> v -> DomRenderHookT t m (TraverseChild t m Int v'))

1796+ -> IntMap v

1797+ -> Event t (p v)

1798+ -> DomRenderHookT t m (IntMap (TraverseChild t m Int v'), Event t (p (TraverseChild t m Int v'))))

1799+ -- ^ The base monad's traversal

1800+ -> (p (TraverseChild t m Int v')

1801+ -> IntMap (IORef (ChildReadyState Int))

1802+ -> IO (IntMap (IORef (ChildReadyState Int))))

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

1804+ -> (IORef (IntMap DOM.Text)

1805+ -> DOM.Text

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

1811+ -> Event t (p v)

1812+ -> HydrationDomBuilderT s t m (IntMap v', Event t (p v'))

1813+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

1814+ doc <- askDocument

1815+ initialEnv <- HydrationDomBuilderT ask

1816+ let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

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

9241818 haveEverBeenReady <- liftIO $ newIORef False

925− placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"

926− lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"

1819+ placeholders <- liftIO $ newIORef IntMap.empty

1820+ lastPlaceholder <- createTextNode doc ("" :: Text)

9271821 let applyDomUpdate p = do

928− applyDomUpdate_ placeholders lastPlaceholderRef p

1822+ applyDomUpdate_ placeholders lastPlaceholder p

9291823 markSelfReady

9301824 liftIO $ writeIORef pendingChange $! mempty

9311825 markSelfReady = do

@@ -936,8 +1830,8 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

9361830 old <- liftIO $ readIORef parentUnreadyChildren

9371831 let new = pred old

9381832 liftIO $ writeIORef parentUnreadyChildren $! new

939− when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

940− markChildReady :: IORef (ChildReadyState k) -> JSM ()

1833+ when (new == 0) $ _hydrationDomBuilderEnv_commitAction initialEnv

1834+ markChildReady :: IORef (ChildReadyState Int) -> JSM ()

9411835 markChildReady childReadyState = do

9421836 liftIO (readIORef childReadyState) >>= \case

9431837 ChildReadyState_Ready -> return ()

@@ -945,82 +1839,191 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

9451839 liftIO $ writeIORef childReadyState ChildReadyState_Ready

9461840 case countedAt of

9471841 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

9491843 (oldUnready, p) <- liftIO $ readIORef pendingChange

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

951− let newUnready = DMap.delete k oldUnready

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

1845+ let newUnready = IntMap.delete k oldUnready

9521846 liftIO $ writeIORef pendingChange (newUnready, p)

953− when (DMap.null newUnready) $ do

1847+ when (IntMap.null newUnready) $ do

9541848 applyDomUpdate p

955− (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

956− let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do

957− readIORef sRef >>= \case

958− ChildReadyState_Ready -> return Nothing

959− ChildReadyState_Unready _ -> do

960− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

961− return $ Just $ Constant sRef

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

963− liftIO $ if DMap.null initialUnready

1849+ (children0 :: IntMap (TraverseChild t m Int v'), children' :: Event t (p (TraverseChild t m Int v')))

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

1851+ let processChild k (TraverseChild e _) = case e of

1852+ Left _ -> pure Nothing

1853+ Right immediate -> do

1854+ readIORef (_traverseChildImmediate_childReadyState immediate) >>= \case

1855+ ChildReadyState_Ready -> return Nothing

1856+ ChildReadyState_Unready _ -> do

1857+ writeIORef (_traverseChildImmediate_childReadyState immediate) $ ChildReadyState_Unready $ Just k

1858+ return $ Just (_traverseChildImmediate_childReadyState immediate)

1859+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0

1860+ liftIO $ if IntMap.null initialUnready

9641861 then writeIORef haveEverBeenReady True

9651862 else do

9661863 modifyIORef' parentUnreadyChildren succ

9671864 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

969− placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0

970− result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r

971− liftIO $ writeIORef placeholders $! placeholders0

972− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append (toNode df)) children0

973− liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

1865+ getHydrationMode >>= \case

1866+ HydrationMode_Hydrating -> addHydrationStepWithSetup (holdIncremental children0 children') $ \children -> do

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

1868+ phs <- traverse (either _traverseChildHydration_delayed (pure . _traverseChildImmediate_placeholder) . _traverseChild_mode) dm

1869+ liftIO $ writeIORef placeholders $! phs

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

9741878 requestDomAction_ $ ffor children' $ \p -> do

9751879 (oldUnready, oldP) <- liftIO $ readIORef pendingChange

9761880 newUnready <- liftIO $ updateChildUnreadiness p oldUnready

9771881 let !newP = p <> oldP

9781882 liftIO $ writeIORef pendingChange (newUnready, newP)

979− when (DMap.null newUnready) $ do

1883+ when (IntMap.null newUnready) $ do

9801884 applyDomUpdate newP

1885+ let result0 = IntMap.map _traverseChild_result children0

1886+ result' = ffor children' $ fmap $ _traverseChild_result

9811887 return (result0, result')

9821888

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+

9831943{-# INLINABLE drawChildUpdate #-}

984−drawChildUpdate :: (MonadIO m, MonadJSM m)

985− => ImmediateDomBuilderEnv t

1944+drawChildUpdate :: (MonadJSM m, Reflex t)

1945+ => HydrationDomBuilderEnv t m

9861946 -> (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)

988− -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)

1947+ -> HydrationDomBuilderT s t m (f a)

1948+ -> DomRenderHookT t m (Compose (TraverseChild t m k) f a)

9891949drawChildUpdate initialEnv markReady child = do

990− childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

1950+ let doc = _hydrationDomBuilderEnv_document initialEnv

9911951 unreadyChildren <- liftIO $ newIORef 0

992− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

993− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

994− { _immediateDomBuilderEnv_parent = toNode df

995− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

996− , _immediateDomBuilderEnv_commitAction = markReady childReadyState

997− }

998− u <- liftIO $ readIORef unreadyChildren

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

1000− return $ Compose (df, placeholder, childReadyState, result)

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

1972+ df <- createDocumentFragment doc

1973+ placeholder <- createTextNode doc ("" :: Text)

1974+ Node.appendChild_ df placeholder

1975+ result <- runReaderT (unHydrationDomBuilderT child) initialEnv

1976+ { _hydrationDomBuilderEnv_parent = Left $ toNode df

1977+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1978+ , _hydrationDomBuilderEnv_commitAction = markReady childReadyState

1979+ }

1980+ u <- liftIO $ readIORef unreadyChildren

1981+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

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

10011990

1002−{-# INLINABLE drawChildUpdateInt #-}

1003−drawChildUpdateInt :: (MonadIO m, MonadJSM m)

1004− => ImmediateDomBuilderEnv t

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

1006− -> ImmediateDomBuilderT t m v'

1007− -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')

1008−drawChildUpdateInt initialEnv markReady child = do

1009− childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing

1010− unreadyChildren <- liftIO $ newIORef 0

1011− df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

1012− (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1013− { _immediateDomBuilderEnv_parent = toNode df

1014− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

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)

1991+{-# SPECIALIZE drawChildUpdate

1992+ :: HydrationDomBuilderEnv Spider HydrationM

1993+ -> (IORef (ChildReadyState Int) -> JSM ())

1994+ -> HydrationDomBuilderT s Spider HydrationM (Identity a)

1995+ -> DomRenderHookT Spider HydrationM (Compose (TraverseChild Spider HydrationM Int) Identity a)

1996+ #-}

1997+

1998+{-# SPECIALIZE drawChildUpdate

1999+ :: HydrationDomBuilderEnv Spider HydrationM

2000+ -> (IORef (ChildReadyState (Some k)) -> JSM ())

2001+ -> HydrationDomBuilderT s Spider HydrationM (f a)

2002+ -> DomRenderHookT Spider HydrationM (Compose (TraverseChild Spider HydrationM (Some k)) f a)

2003+ #-}

10202004

1021−mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

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

2023+ => Element er d t -> m (Dynamic t Bool)

10222024mkHasFocus 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

10242027 holdDyn initialFocus $ leftmost

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

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

@@ -1029,39 +2032,49 @@ mkHasFocus e = do

10292032insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()

10302033insertBefore new existing = do

10312034 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

10332038

1034−instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

1035− type Performable (ImmediateDomBuilderT t m) = Performable m

2039+instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT s t m) where

2040+ type Performable (HydrationDomBuilderT s t m) = Performable m

10362041 {-# INLINABLE performEvent_ #-}

10372042 performEvent_ e = lift $ performEvent_ e

10382043 {-# INLINABLE performEvent #-}

10392044 performEvent e = lift $ performEvent e

10402045

1041−instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where

2046+instance PostBuild t m => PostBuild t (HydrationDomBuilderT s t m) where

10422047 {-# INLINABLE getPostBuild #-}

10432048 getPostBuild = lift getPostBuild

10442049

1045−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ImmediateDomBuilderT t m) where

2050+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDomBuilderT s t m) where

10462051 {-# INLINABLE newEventWithTrigger #-}

10472052 newEventWithTrigger = lift . newEventWithTrigger

10482053 {-# INLINABLE newFanEventWithTrigger #-}

10492054 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

10502055

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

10522065 {-# INLINABLE newTriggerEvent #-}

1053− newTriggerEvent = ImmediateDomBuilderT . lift . lift $ newTriggerEvent

2066+ newTriggerEvent = DomRenderHookT . lift $ newTriggerEvent

10542067 {-# INLINABLE newTriggerEventWithOnComplete #-}

1055− newTriggerEventWithOnComplete = ImmediateDomBuilderT . lift . lift $ newTriggerEventWithOnComplete

2068+ newTriggerEventWithOnComplete = DomRenderHookT . lift $ newTriggerEventWithOnComplete

10562069 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

1057− newEventWithLazyTriggerWithOnComplete f = ImmediateDomBuilderT . lift . lift $ newEventWithLazyTriggerWithOnComplete f

2070+ newEventWithLazyTriggerWithOnComplete f = DomRenderHookT . lift $ newEventWithLazyTriggerWithOnComplete f

10582071

1059−instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where

1060− type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m

2072+instance HasJSContext m => HasJSContext (HydrationDomBuilderT s t m) where

2073+ type JSContextPhantom (HydrationDomBuilderT s t m) = JSContextPhantom m

10612074 askJSContext = lift askJSContext

10622075

1063−instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where

1064− type Ref (ImmediateDomBuilderT t m) = Ref m

2076+instance MonadRef m => MonadRef (HydrationDomBuilderT s t m) where

2077+ type Ref (HydrationDomBuilderT s t m) = Ref m

10652078 {-# INLINABLE newRef #-}

10662079 newRef = lift . newRef

10672080 {-# INLINABLE readRef #-}

@@ -1069,12 +2082,12 @@ instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where

10692082 {-# INLINABLE writeRef #-}

10702083 writeRef r = lift . writeRef r

10712084

1072−instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where

2085+instance MonadAtomicRef m => MonadAtomicRef (HydrationDomBuilderT s t m) where

10732086 {-# INLINABLE atomicModifyRef #-}

10742087 atomicModifyRef r = lift . atomicModifyRef r

10752088

1076−instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where

1077− type JSX (ImmediateDomBuilderT t m) = JSX m

2089+instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT s t m) where

2090+ type JSX (HydrationDomBuilderT s t m) = JSX m

10782091 liftJS = lift . liftJS

10792092

10802093type family EventType en where

@@ -1532,11 +2545,11 @@ getTouchEvent = do

15322545 , _touchEventResult_touches = touches

15332546 }

15342547

1535−instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where

2548+instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where

15362549 {-# INLINABLE sample #-}

15372550 sample = lift . sample

15382551

1539−instance MonadHold t m => MonadHold t (ImmediateDomBuilderT t m) where

2552+instance MonadHold t m => MonadHold t (HydrationDomBuilderT s t m) where

15402553 {-# INLINABLE hold #-}

15412554 hold v0 v' = lift $ hold v0 v'

15422555 {-# INLINABLE holdDyn #-}

@@ -1558,7 +2571,7 @@ data Window t = Window

15582571 , _window_raw :: DOM.Window

15592572 }

15602573

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)

15622575wrapWindow wv _ = do

15632576 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName

15642577 return $ Window

reflex-dom-core/src/Reflex/Dom/Core.hs−1

@@ -2,7 +2,6 @@ module Reflex.Dom.Core (module X) where

33import Reflex as X hiding (askEvents)

44import Reflex.Dom.Builder.Class as X

5−import Reflex.Dom.Builder.Hydration as X hiding (askEvents, makeElement, ChildReadyState, drawChildUpdate, append, wrap, traverseIntMapWithKeyWithAdjust', hoistTraverseIntMapWithKeyWithAdjust)

65import Reflex.Dom.Builder.Immediate as X

76import Reflex.Dom.Builder.InputDisabled as X

87import 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_)

2020import Reflex.Adjustable.Class

2121import Reflex.Class

2222import Reflex.Dom.Builder.Immediate

23−import Reflex.Dom.Builder.Hydration

2423import Reflex.Dom.Class

2524import Reflex.Host.Class

2625import Reflex.PerformEvent.Base

@@ -30,8 +29,6 @@ import Reflex.TriggerEvent.Base

3029import Reflex.TriggerEvent.Class

3130import qualified Reflex.TriggerEvent.Base as TriggerEvent

3231

33−import Reflex.Dom.Specializations () -- For SPECIALIZATION pragmas, which are always re-exported

34−

3532import Control.Concurrent

3633import Control.Lens

3734import Control.Monad

@@ -58,14 +55,14 @@ import qualified GHCJS.DOM.Types as DOM

5855import Reflex.Profiled

5956#endif

6057

61−{-# INLINE mainHydrationWidget #-}

62−mainHydrationWidget :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

63−mainHydrationWidget = mainHydrationWidget'

58+{-# INLINE mainHydrationWidgetWithHead #-}

59+mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

60+mainHydrationWidgetWithHead = mainHydrationWidgetWithHead'

6461

65−{-# INLINABLE mainHydrationWidget' #-}

66−-- | Warning: `mainHydrationWidget'` is provided only as performance tweak. It is expected to disappear in future releases.

67−mainHydrationWidget' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()

68−mainHydrationWidget' = mainHydrationWidgetWithSwitchoverAction' (pure ())

62+{-# INLINABLE mainHydrationWidgetWithHead' #-}

63+-- | Warning: `mainHydrationWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.

64+mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> JSM ()

65+mainHydrationWidgetWithHead' = mainHydrationWidgetWithSwitchoverAction' (pure ())

6966

7067{-# INLINE mainHydrationWidgetWithSwitchoverAction #-}

7168mainHydrationWidgetWithSwitchoverAction :: IO () -> (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> JSM ()

@@ -83,7 +80,7 @@ mainHydrationWidgetWithSwitchoverAction' switchoverAction head' body = do

8380attachHydrationWidget

8481 :: IO ()

8582 -> IORef HydrationMode

86− -> IORef [(Node, HydrationRunnerT DomTimeline (PostBuildT DomTimeline (WithJSContextSingleton () (PerformEventT DomTimeline DomHost))) ())]

83+ -> IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())]

8784 -> JSContextSingleton ()

8885 -> (EventChannel -> Event DomTimeline () -> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ()))))

8986 -> IO (a, FireCommand DomTimeline DomHost)

@@ -106,7 +103,7 @@ attachHydrationWidget switchoverAction hydrationMode rootNodesRef jsSing w = do

106103 liftIO $ switchoverAction

107104 pure (result, fc)

108105

109−type HydrationWidget x a = HydrationDomBuilderT DomTimeline (DomCoreWidget x) a

106+type HydrationWidget x a = HydrationDomBuilderT HydrationDomSpace DomTimeline (DomCoreWidget x) a

110107

111108-- | A widget that isn't attached to any particular part of the DOM hierarchy

112109type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)

@@ -152,52 +149,6 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM

152149 return (events, postBuildTriggerRef)

153150 liftIO $ processAsyncEvents events fc

154151

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−

201152{-# INLINE mainWidget #-}

202153mainWidget :: (forall x. Widget x ()) -> JSM ()

203154mainWidget = mainWidget'

@@ -249,7 +200,7 @@ runDomHost = runSpiderHost

249200 . runProfiledM

250201#endif

251202

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)

253204

254205{-# INLINABLE attachWidget #-}

255206attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

@@ -263,19 +214,24 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do

263214 headFragment <- createDocumentFragment doc

264215 bodyElement <- getBodyUnchecked doc

265216 bodyFragment <- createDocumentFragment doc

217+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

266218 (events, fc) <- liftIO . attachWidget'' $ \events -> do

267219 let (headWidget, bodyWidget) = widgets

268220 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

269221 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c

270222 go w df = do

271223 unreadyChildren <- liftIO $ newIORef 0

272− let builderEnv = ImmediateDomBuilderEnv

273− { _immediateDomBuilderEnv_document = toDocument doc

274− , _immediateDomBuilderEnv_parent = toNode df

275− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

276− , _immediateDomBuilderEnv_commitAction = return () --TODO

224+ delayed <- liftIO $ newIORef $ pure ()

225+ let builderEnv = HydrationDomBuilderEnv

226+ { _hydrationDomBuilderEnv_document = toDocument doc

227+ , _hydrationDomBuilderEnv_parent = Left $ toNode df

228+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

229+ , _hydrationDomBuilderEnv_commitAction = return () --TODO

230+ , _hydrationDomBuilderEnv_switchover = never

231+ , _hydrationDomBuilderEnv_delayed = delayed

232+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

277233 }

278− runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

234+ runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing

279235 rec b <- go (headWidget a) headFragment

280236 a <- go (bodyWidget b) bodyFragment

281237 return (events, postBuildTriggerRef)

@@ -294,16 +250,21 @@ attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> J

294250attachWidget' rootElement jsSing w = do

295251 doc <- getOwnerDocumentUnchecked rootElement

296252 df <- createDocumentFragment doc

253+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

297254 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do

298255 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

299256 unreadyChildren <- liftIO $ newIORef 0

300− let builderEnv = ImmediateDomBuilderEnv

301− { _immediateDomBuilderEnv_document = toDocument doc

302− , _immediateDomBuilderEnv_parent = toNode df

303− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

304− , _immediateDomBuilderEnv_commitAction = return () --TODO

257+ delayed <- liftIO $ newIORef $ pure ()

258+ let builderEnv = HydrationDomBuilderEnv

259+ { _hydrationDomBuilderEnv_document = toDocument doc

260+ , _hydrationDomBuilderEnv_parent = Left $ toNode df

261+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

262+ , _hydrationDomBuilderEnv_commitAction = return () --TODO

263+ , _hydrationDomBuilderEnv_switchover = never

264+ , _hydrationDomBuilderEnv_delayed = delayed

265+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode

305266 }

306− a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

267+ a <- runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing

307268 return ((a, events), postBuildTriggerRef)

308269 replaceElementContents rootElement df

309270 liftIO $ processAsyncEvents events fc

@@ -353,7 +314,7 @@ runApp' app = withJSContextSingleton $ \jsSing -> do

353314 body <- getBodyUnchecked doc

354315 win <- getDefaultViewUnchecked doc

355316 rec o <- attachWidget body jsSing $ do

356− w <- lift $ wrapWindow win $ _appOutput_windowConfig o

317+ w <- wrapWindow win $ _appOutput_windowConfig o

357318 app $ AppInput

358319 { _appInput_window = w

359320 }

reflex-dom-core/src/Reflex/Dom/Prerender.hs+20−16

@@ -38,8 +38,7 @@ import GHCJS.DOM.Types (MonadJSM)

3838import Reflex hiding (askEvents)

3939import Reflex.Dom.Builder.Class

4040import Reflex.Dom.Builder.InputDisabled

41−import Reflex.Dom.Builder.Immediate (ImmediateDomBuilderT, insertBefore, deleteBetweenExclusive, runImmediateDomBuilderT, ImmediateDomBuilderEnv(..), GhcjsDomSpace)

42−import Reflex.Dom.Builder.Hydration

41+import Reflex.Dom.Builder.Immediate

4342import Reflex.Dom.Builder.Static

4443import Reflex.Host.Class

4544

@@ -93,14 +92,14 @@ class Prerender t m | m -> t where

9392 -- hydration will fail.

9493 prerenderImpl :: m (a, b) -> ((PrerenderClientConstraint t (Client m)) => Client m b) -> m (Maybe a, Dynamic t b)

9594

96−instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (ImmediateDomBuilderT t m) where

97− type Client (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m

95+instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (HydrationDomBuilderT GhcjsDomSpace t m) where

96+ type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m

9897 prerenderImpl _ client = (,) Nothing . pure <$> client

9998

100−instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT t m) where

101− -- | PostBuildT is needed here because we delay running the immediate builder

99+instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT HydrationDomSpace t m) where

100+ -- | PostBuildT is needed here because we delay running the client builder

102101 -- 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)

104103 -- | Runs the server widget up until switchover, then replaces it with the

105104 -- client widget.

106105 prerenderImpl server client = do

@@ -109,25 +108,30 @@ instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerend

109108 doc <- askDocument

110109 df <- Document.createDocumentFragment doc

111110 unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren

112− let immediateEnv = ImmediateDomBuilderEnv

113− { _immediateDomBuilderEnv_document = doc

114− , _immediateDomBuilderEnv_parent = DOM.toNode df

115− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

116− , _immediateDomBuilderEnv_commitAction = pure ()

117− }

111+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate

118112 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+ }

119122 (a, b0) <- lift $ runHydrationDomBuilderT server (env { _hydrationDomBuilderEnv_delayed = delayed }) events

120123 (b', trigger) <- newTriggerEvent

121124 getHydrationMode >>= \case

122125 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

124128 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

126130 insertBefore df =<< deleteToPrerenderEnd

127131 (,) (Just a) <$> holdDyn b0 b'

128132

129133instance 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

131135 prerenderImpl server _ = do

132136 _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()

133137 (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)

4242import Network.Socket

4343import Network.Wai

4444import Network.WebSockets

45−import Reflex.Dom.Builder.Immediate (GhcjsDomSpace)

4645import Reflex.Dom.Core

4746import Reflex.Patch.DMapWithMove

4847import System.Directory

reflex-dom/benchmarks/krausest.hs+1−2

@@ -26,8 +26,7 @@ type TableDiff = PatchIntMap Row

2626main :: IO ()

2727main = do

2828 seed <- randomIO

29−-- mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed) -- Immediate builder

30− mainHydrationWidgetWithHeadImmediate' headW (bodyW seed) -- Hydration builder

29+ mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed)

3130

3231titleW :: DomBuilder t m => m ()

3332titleW = text "Reflex-dom keyed"

reflex-dom/src/Reflex/Dom.hs+2−1

@@ -2,5 +2,6 @@ module Reflex.Dom (module X) where

33import Foreign.JavaScript.Orphans ()

44import Reflex.Dom.Core as X hiding (mainWidget, mainWidgetInElementById, mainWidgetWithCss,

5− mainWidgetWithHead, mainWidgetWithHead', runApp', mainHydrationWidgetWithHeadImmediate)

5+ mainWidgetWithHead, mainWidgetWithHead', runApp',

6+ mainHydrationWidgetWithHead, mainHydrationWidgetWithHead')

67import Reflex.Dom.Internal as X

reflex-dom/src/Reflex/Dom/Internal.hs+12−14

@@ -4,18 +4,24 @@

44{-# LANGUAGE RankNTypes #-}

55{-# LANGUAGE TypeFamilies #-}

66module Reflex.Dom.Internal

7− (module Main, run, mainWidget, mainWidgetWithHead, mainWidgetWithCss,

8− mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHead, mainHydrationWidgetWithHead', mainHydrationWidgetWithHeadImmediate, mainHydrationWidgetWithHeadImmediate') where

7+ ( module Main

8+ , run

9+ , mainWidget

10+ , mainWidgetWithHead, mainWidgetWithCss, mainWidgetWithHead', mainWidgetInElementById, runApp'

11+ , mainHydrationWidgetWithHead, mainHydrationWidgetWithHead'

12+ ) where

913

1014import Data.ByteString (ByteString)

1115import Data.Text (Text)

1216import Reflex.Dom.Core (Widget)

1317import Reflex.Dom.Main as Main hiding

1418 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

15− mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)

19+ mainWidgetWithHead', mainWidgetInElementById, runApp',

20+ mainHydrationWidgetWithHead, mainHydrationWidgetWithHead')

1621import qualified Reflex.Dom.Main as Main

1722 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

18− mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)

23+ mainWidgetWithHead', mainWidgetInElementById, runApp',

24+ mainHydrationWidgetWithHead, mainHydrationWidgetWithHead')

1925

2026#if defined(ghcjs_HOST_OS)

2127run :: a -> a

@@ -103,17 +109,9 @@ runApp' app = run $ Main.runApp' app

103109{-# INLINE runApp' #-}

104110

105111mainHydrationWidgetWithHead :: (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

107113{-# INLINE mainHydrationWidgetWithHead #-}

108114

109115mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> IO ()

110−mainHydrationWidgetWithHead' h b = run $ Main.mainHydrationWidget' h b

116+mainHydrationWidgetWithHead' h b = run $ Main.mainHydrationWidgetWithHead' h b

111117{-# 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' #-}