404fa3b · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Rework Prerender for hydration

404fa3bTom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+11−174

compare with develop

unifiedsplit

@@ -46,46 +46,11 @@ module Reflex.Dom.Builder.Hydration

46 , askEvents

47 , append

48 , textNodeInternal

49− , deleteBetweenExclusive

50− , extractBetweenExclusive

51− , deleteBetweenInclusive

52− , extractBetweenInclusive

53− , deleteUpTo

54− , extractUpTo

55 , SupportsHydrationDomBuilder

49 , SupportsHydrationDomBuilder

56− , collectUpTo

57− , collectUpToGivenParent

58 , EventFilterTriggerRef (..)

50 , EventFilterTriggerRef (..)

59 , wrap

51 , wrap

60 , makeElement

52 , makeElement

61− , GhcjsDomHandler (..)

62− , GhcjsDomHandler1 (..)

63− , GhcjsDomEvent (..)

64− , GhcjsEventFilter (..)

65− , Pair1 (..)

66− , Maybe1 (..)

67− , GhcjsEventSpec (..)

68− , HasDocument (..)

69− , ghcjsEventSpec_filters

70− , ghcjsEventSpec_handler

71− , GhcjsEventHandler (..)

72−#ifndef USE_TEMPLATE_HASKELL

73− , phantom2

74−#endif

75 , drawChildUpdate

53 , drawChildUpdate

76− , ChildReadyState (..)

77− , ChildReadyStateInt (..)

78− , mkHasFocus

79− , insertBefore

80− , EventType

81− , defaultDomEventHandler

82− , defaultDomWindowEventHandler

83− , withIsEvent

84− , showEventName

85− , elementOnEventName

86− , windowOnEventName

87− , wrapDomEvent

88− , subscribeDomEvent

89 -- * Internal

54 -- * Internal

90 , traverseDMapWithKeyWithAdjust'

55 , traverseDMapWithKeyWithAdjust'

91 , hoistTraverseWithKeyWithAdjust

56 , hoistTraverseWithKeyWithAdjust

@@ -98,7 +63,7 @@ import Reflex.Adjustable.Class

98import Reflex.Class as Reflex

63import Reflex.Class as Reflex

99import qualified Reflex.Spider.Internal as Spider

64import qualified Reflex.Spider.Internal as Spider

100import Reflex.Dom.Builder.Class

65import Reflex.Dom.Builder.Class

101−import Reflex.Dom.Builder.Immediate hiding (askParent, append, extractBetweenExclusive, extractUpTo, collectUpToGivenParent, askEvents, wrap, makeElement, textNodeInternal, commentNodeInternal, wrapDomEvent, mkHasFocus, insertBefore, deleteBetweenExclusive, traverseIntMapWithKeyWithAdjust', traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, deleteUpTo, collectUpTo, hoistTraverseIntMapWithKeyWithAdjust, drawChildUpdate, subscribeDomEvent)

66+import Reflex.Dom.Builder.Immediate hiding (askEvents, askParent, append, wrap, makeElement, textNodeInternal, commentNodeInternal, traverseIntMapWithKeyWithAdjust', traverseDMapWithKeyWithAdjust', hoistTraverseWithKeyWithAdjust, hoistTraverseIntMapWithKeyWithAdjust, drawChildUpdate)

102import Reflex.Dynamic

67import Reflex.Dynamic

103import Reflex.Host.Class

68import Reflex.Host.Class

104import qualified Reflex.Patch.DMap as PatchDMap

69import qualified Reflex.Patch.DMap as PatchDMap

@@ -232,8 +197,6 @@ data HydrationDomBuilderEnv = HydrationDomBuilderEnv

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

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

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

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

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

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

235− , _hydrationDomBuilderEnv_prerenderDepth :: {-# UNPACK #-} !(IORef Word)

236− -- ^ TODO

237 }

200 }

238

201

239data DOM t m

202data DOM t m

@@ -264,7 +227,6 @@ runDOMTree = \case

264

227

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

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

266-- State contains reference to the previous node sibling, if any.

229-- State contains reference to the previous node sibling, if any.

267−-- TODO: This probably doesn't need to be a full transformer of `m`, seems like we only need (Reflex t, MonadJSM m, MonadReflexCreateTrigger t m, DomRenderHook t m)

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

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

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

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

270#if MIN_VERSION_base(4,9,1)

232#if MIN_VERSION_base(4,9,1)

@@ -273,13 +235,19 @@ newtype HydrationRunnerT t m a = HydrationRunnerT { unHydrationRunnerT :: StateT

273 )

235 )

274

236

275localRunner :: Monad m => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a

237localRunner :: Monad m => HydrationRunnerT t m a -> Maybe Node -> Node -> HydrationRunnerT t m a

276−localRunner (HydrationRunnerT m) prev = HydrationRunnerT . lift . lift . runReaderT (evalStateT m prev)

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

277

239

278runHydrationRunnerT

240runHydrationRunnerT

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

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

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

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

281runHydrationRunnerT (HydrationRunnerT m) prev parent = runDomRenderHookT (runReaderT (evalStateT m prev) parent)

243runHydrationRunnerT (HydrationRunnerT m) prev parent = runDomRenderHookT (runReaderT (evalStateT m prev) parent)

282

244

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

246+ {-# INLINABLE newEventWithTrigger #-}

247+ newEventWithTrigger = lift . newEventWithTrigger

248+ {-# INLINABLE newFanEventWithTrigger #-}

249+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

250+

283instance MonadTrans (HydrationRunnerT t) where

251instance MonadTrans (HydrationRunnerT t) where

284 lift = HydrationRunnerT . lift . lift . lift

252 lift = HydrationRunnerT . lift . lift . lift

285

253

@@ -288,9 +256,6 @@ hydrateDOM dom = getHydrationMode >>= \case

288 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify (dom :)

256 HydrationMode_Hydrating -> HydrationDomBuilderT $ modify (dom :)

289 HydrationMode_Immediate -> pure ()

257 HydrationMode_Immediate -> pure ()

290

258

291−-- TODO probably can separate these two monads entirely, they have grown apart

292−-- over the course of refactoring

293−

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

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

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

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

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

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

@@ -404,10 +369,6 @@ getPreviousNode = HydrationRunnerT get

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

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

405setPreviousNode = HydrationRunnerT . put

370setPreviousNode = HydrationRunnerT . put

406

371

407−{-# INLINABLE getPrerenderDepth #-}

408−getPrerenderDepth :: MonadIO m => HydrationDomBuilderT t m Word

409−getPrerenderDepth = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_prerenderDepth)

410−

411{-# INLINABLE getParent #-}

372{-# INLINABLE getParent #-}

412getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node

373getParent :: MonadIO m => HydrationDomBuilderT t m DOM.Node

413getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)

374getParent = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationDomBuilderEnv_parent)

@@ -428,7 +389,6 @@ getHydrationMode = liftIO . readIORef =<< HydrationDomBuilderT (asks _hydrationD

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

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

429askEvents = HydrationDomBuilderT . lift . lift . DomRenderHookT . lift $ TriggerEventT.askEvents

390askEvents = HydrationDomBuilderT . lift . lift . DomRenderHookT . lift $ TriggerEventT.askEvents

430

391

431−

432{-# INLINABLE makeNodeInternal #-}

392{-# INLINABLE makeNodeInternal #-}

433makeNodeInternal

393makeNodeInternal

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

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

@@ -469,74 +429,8 @@ hydrateNode check constructor = do

469 setPreviousNode $ Just $ toNode n

429 setPreviousNode $ Just $ toNode n

470 return n

430 return n

471

431

472−

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

474−-- all nodes between s and e will be removed, but s and e will not be removed

475−deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

476−deleteBetweenExclusive s e = do

477− df <- createDocumentFragment =<< getOwnerDocumentUnchecked s

478− extractBetweenExclusive df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant

479−

480−-- | s and e must both be children of the same node and s must precede e; all

481−-- nodes between s and e will be moved into the given DocumentFragment, but s

482−-- and e will not be moved

483−extractBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()

484−extractBetweenExclusive df s e = liftJSM $ do

485− f <- eval ("(function(df,s,e) { var x; for(;;) { x = s['nextSibling']; if(e===x) { break; }; df['appendChild'](x); } })" :: Text)

486− void $ call f f (df, s, e)

487−

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

489−-- all nodes between s and e will be removed, including s and e

490−deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

491−deleteBetweenInclusive s e = do

492− df <- createDocumentFragment =<< getOwnerDocumentUnchecked s

493− extractBetweenInclusive df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant

494−

495−-- | s and e must both be children of the same node and s must precede e; all

496−-- nodes between s and e will be moved into the given DocumentFragment,

497−-- including s and e

498−extractBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()

499−extractBetweenInclusive df s e = liftJSM $ do

500− f <- eval ("(function(df,s,e) { var x = s; var next; for(;;) { next = x['nextSibling']; df['appendChild'](x); if(e===x) { break; }; x = next; } })" :: Text)

501− void $ call f f (df, s, e)

502−

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

504−-- s and all nodes between s and e will be removed, but e will not be removed

505−{-# INLINABLE deleteUpTo #-}

506−deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

507−deleteUpTo s e = do

508− df <- createDocumentFragment =<< getOwnerDocumentUnchecked s

509− extractUpTo df s e -- In many places in HydrationDomBuilderT, we assume that things always have a parent; by adding them to this DocumentFragment, we maintain that invariant

510−

511−extractUpTo :: (MonadJSM m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()

512−#ifdef ghcjs_HOST_OS

513−--NOTE: Although wrapping this javascript in a function seems unnecessary, GHCJS's optimizer will break it if it is entered without that wrapping (as of 2017-09-04)

514−foreign import javascript unsafe

515− "(function() { var x = $2; while(x !== $3) { var y = x['nextSibling']; $1['appendChild'](x); x = y; } })()"

516− extractUpTo_ :: DOM.DocumentFragment -> DOM.Node -> DOM.Node -> IO ()

517−extractUpTo df s e = liftJSM $ extractUpTo_ df (toNode s) (toNode e)

518−#else

519−extractUpTo df s e = liftJSM $ do

520− f <- eval ("(function(df,s,e){ var x = s; var y; for(;;) { y = x['nextSibling']; df['appendChild'](x); if(e===y) { break; } x = y; } })" :: Text)

521− void $ call f f (df, s, e)

522−#endif

523−

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

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

525

433

526−{-# INLINABLE collectUpTo #-}

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

528−collectUpTo s e = do

529− currentParent <- getParentNodeUnchecked e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

530− collectUpToGivenParent currentParent s e

531−

532−{-# INLINABLE collectUpToGivenParent #-}

533−collectUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment

534−collectUpToGivenParent currentParent s e = do

535− doc <- getOwnerDocumentUnchecked currentParent

536− df <- createDocumentFragment doc

537− extractUpTo df s e

538− return df

539−

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

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

541{-# INLINABLE wrap #-}

435{-# INLINABLE wrap #-}

542wrap

436wrap

@@ -626,15 +520,8 @@ makeElement elementTag cfg child = do

626 let env' = env { _hydrationDomBuilderEnv_parent = parent}

520 let env' = env { _hydrationDomBuilderEnv_parent = parent}

627 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') []

521 (result, childDom) <- HydrationDomBuilderT $ lift $ lift $ runStateT (runReaderT (unHydrationDomBuilderT child) env') []

628 wrapResult <- liftIO newEmptyMVar

522 wrapResult <- liftIO newEmptyMVar

629− prerenderDepth <- getPrerenderDepth

630 let activateElement = do

523 let activateElement = do

631− e <- case prerenderDepth of

632− 0 -> hydrateNode hasSSRAttribute DOM.Element

524+ e <- hydrateNode hasSSRAttribute DOM.Element

633− _ -> do

634− e <- buildElement

635− maybe (askParent >>= \p -> Node.appendChild_ p e) (insertAfter e) =<< getPreviousNode

636− setPreviousNode $ Just $ toNode e

637− pure e

638 -- Update the parent node used by the children

525 -- Update the parent node used by the children

639 liftIO $ writeIORef parent $ toNode e

526 liftIO $ writeIORef parent $ toNode e

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

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

@@ -674,16 +561,9 @@ textNodeInternal !t mSetContents = getHydrationMode >>= \case

674 pure n

561 pure n

675 HydrationMode_Hydrating -> do

562 HydrationMode_Hydrating -> do

676 doc <- askDocument

563 doc <- askDocument

677− prerenderDepth <- getPrerenderDepth

678 let activateText = do

564 let activateText = do

679 liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)

565 liftIO $ putStrLn $ "Action: Text: " <> show (DOM.toJSString t)

680− n <- case prerenderDepth of

681− 0 -> hydrateNode (const $ pure True) DOM.Text

566+ n <- hydrateNode (const $ pure True) DOM.Text

682− _ -> do

683− tn <- createTextNode doc t

684− maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode

685− setPreviousNode $ Just $ toNode tn

686− pure tn

687 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

567 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

688 hydrateDOM $ DOM_Node activateText

568 hydrateDOM $ DOM_Node activateText

689 pure $ error "textNodeInternal: DOM.Text"

569 pure $ error "textNodeInternal: DOM.Text"

@@ -697,16 +577,9 @@ commentNodeInternal !t mSetContents = getHydrationMode >>= \case

697 pure n

577 pure n

698 HydrationMode_Hydrating -> do

578 HydrationMode_Hydrating -> do

699 doc <- askDocument

579 doc <- askDocument

700− prerenderDepth <- getPrerenderDepth

701 let activateComment = do

580 let activateComment = do

702 liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)

581 liftIO $ putStrLn $ "Action: Comment: " <> show (DOM.toJSString t)

703− n <- case prerenderDepth of

704− 0 -> hydrateNode (const $ pure True) DOM.Comment

582+ n <- hydrateNode (const $ pure True) DOM.Comment

705− _ -> do

706− tn <- createComment doc t

707− maybe (askParent >>= \p -> Node.appendChild_ p tn) (insertAfter tn) =<< getPreviousNode

708− setPreviousNode $ Just $ toNode tn

709− pure tn

710 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

583 mapM_ (requestDomAction_ . fmap (setNodeValue n . Just)) mSetContents

711 hydrateDOM $ DOM_Node activateComment

584 hydrateDOM $ DOM_Node activateComment

712 pure $ error "commentNodeInternal: DOM.Comment"

585 pure $ error "commentNodeInternal: DOM.Comment"

@@ -1446,25 +1319,12 @@ drawChildUpdateInt initialEnv markReady child = do

1446 , placeholder, childReadyState, result

1319 , placeholder, childReadyState, result

1447 )

1320 )

1448

1321

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

1450−mkHasFocus e = do

1451− let initialFocus = False --TODO: Actually get the initial focus of the element

1452− holdDyn initialFocus $ leftmost

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

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

1455− ]

1456−

1457insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()

1322insertAfter :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()

1458insertAfter new existing = do

1323insertAfter new existing = do

1459 liftIO $ putStrLn "insertAfter"

1324 liftIO $ putStrLn "insertAfter"

1460 p <- getParentNodeUnchecked existing

1325 p <- getParentNodeUnchecked existing

1461 Node.getNextSibling existing >>= DOM.insertBefore_ p new

1326 Node.getNextSibling existing >>= DOM.insertBefore_ p new

1462

1327

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

1464−insertBefore new existing = do

1465− p <- getParentNodeUnchecked existing

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

1467−

1468instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where

1328instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where

1469 type Performable (HydrationDomBuilderT t m) = Performable m

1329 type Performable (HydrationDomBuilderT t m) = Performable m

1470 {-# INLINABLE performEvent_ #-}

1330 {-# INLINABLE performEvent_ #-}

@@ -1482,12 +1342,6 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydrationDo

1482 {-# INLINABLE newFanEventWithTrigger #-}

1342 {-# INLINABLE newFanEventWithTrigger #-}

1483 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

1343 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

1484

1344

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

1486− {-# INLINABLE newEventWithTrigger #-}

1487− newEventWithTrigger = lift . newEventWithTrigger

1488− {-# INLINABLE newFanEventWithTrigger #-}

1489− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

1490−

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

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

1492 {-# INLINABLE newTriggerEvent #-}

1346 {-# INLINABLE newTriggerEvent #-}

1493 newTriggerEvent = HydrationDomBuilderT . lift . lift $ newTriggerEvent

1347 newTriggerEvent = HydrationDomBuilderT . lift . lift $ newTriggerEvent

@@ -1525,23 +1379,6 @@ instance (HasJS x m, ReflexHost t) => HasJS x (HydrationDomBuilderT t m) where

1525 type JSX (HydrationDomBuilderT t m) = JSX m

1379 type JSX (HydrationDomBuilderT t m) = JSX m

1526 liftJS = lift . liftJS

1380 liftJS = lift . liftJS

1527

1381

1528−{-# INLINABLE wrapDomEvent #-}

1529−wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)

1530−wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue

1531−

1532−{-# INLINABLE subscribeDomEvent #-}

1533−subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))

1534− -> EventM e event (Maybe a)

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

1536− -> EventTrigger t a

1537− -> JSM (JSM ())

1538−subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do

1539− mv <- getValue

1540− forM_ mv $ \v -> liftIO $ do

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

1542− etr <- newIORef $ Just et

1543− writeChan eventChan [EventTriggerRef etr :=> TriggerInvocation v (return ())]

1544−

1545instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where

1382instance MonadSample t m => MonadSample t (HydrationDomBuilderT t m) where

1546 {-# INLINABLE sample #-}

1383 {-# INLINABLE sample #-}

1547 sample = lift . sample

1384 sample = lift . sample

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+7−2

@@ -53,6 +53,7 @@ import Reflex.Host.Class

53import Reflex.PerformEvent.Base

54import Reflex.PerformEvent.Class

55import Reflex.PostBuild.Base

56+import Reflex.PostBuild.Class

56import Reflex.TriggerEvent.Class

57import Reflex.TriggerEvent.Class

57import System.Random (randomRIO)

58import System.Random (randomRIO)

@@ -82,6 +83,10 @@ runStaticDomBuilderT (StaticDomBuilderT a) e = do

82 (result, a') <- runStateT (runReaderT a e) []

83 (result, a') <- runStateT (runReaderT a e) []

83 return (result, mconcat $ reverse a')

84 return (result, mconcat $ reverse a')

86+instance PostBuild t m => PostBuild t (StaticDomBuilderT t m) where

87+ {-# INLINABLE getPostBuild #-}

88+ getPostBuild = lift getPostBuild

89+

85instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where

90instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where

86 {-# INLINABLE newEventWithTrigger #-}

91 {-# INLINABLE newEventWithTrigger #-}

87 newEventWithTrigger = lift . newEventWithTrigger

92 newEventWithTrigger = lift . newEventWithTrigger

@@ -356,7 +361,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

356 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

361 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

357

362

358--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

363--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

359−type StaticWidget x = PostBuildT DomTimeline (StaticDomBuilderT DomTimeline (PerformEventT DomTimeline DomHost))

364+type StaticWidget x = StaticDomBuilderT DomTimeline (PostBuildT DomTimeline (PerformEventT DomTimeline DomHost))

360

365

361{-# INLINE renderStatic #-}

366{-# INLINE renderStatic #-}

362renderStatic :: StaticWidget x a -> IO (a, ByteString)

367renderStatic :: StaticWidget x a -> IO (a, ByteString)

@@ -364,7 +369,7 @@ renderStatic w = do

364 runDomHost $ do

369 runDomHost $ do

365 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

370 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

366 let env0 = StaticDomBuilderEnv True Nothing

371 let env0 = StaticDomBuilderEnv True Nothing

367− ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

372+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runPostBuildT (runStaticDomBuilderT w env0) postBuild

368 mPostBuildTrigger <- readRef postBuildTriggerRef

373 mPostBuildTrigger <- readRef postBuildTriggerRef

369 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

374 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

370 bs' <- sample bs

375 bs' <- sample bs

reflex-dom-core/src/Reflex/Dom/Prerender.hs+84−62

@@ -15,31 +15,32 @@

15module Reflex.Dom.Prerender

16 ( Prerender (..)

17 , prerender

18− , PrerenderClientConstraint

19 ) where

18 ) where

21import Control.Lens ((&), (.~))

20import Control.Lens ((&), (.~))

22import Control.Monad.Reader

21import Control.Monad.Reader

23import Control.Monad.Ref (Ref, MonadRef)

22import Control.Monad.Ref (Ref, MonadRef)

23+import Data.Bifunctor (bimap)

24import Data.Constraint

25import Data.Default

26import Data.IORef (modifyIORef', readIORef, newIORef)

27import Data.String (IsString)

28import qualified GHCJS.DOM.Element as Element

29import qualified GHCJS.DOM.Types as DOM

30+import qualified GHCJS.DOM.Document as Document

30import qualified Data.Map as Map

31import qualified Data.Map as Map

31import Foreign.JavaScript.TH

32import Foreign.JavaScript.TH

32import GHC.IORef (IORef)

33import GHC.IORef (IORef)

33import GHCJS.DOM.Types (MonadJSM)

34import GHCJS.DOM.Types (MonadJSM)

34−import Reflex

35+import Reflex hiding (askEvents)

35import Reflex.Dom.Builder.Class

36import Reflex.Dom.Builder.Class

36import Reflex.Dom.Builder.InputDisabled

37import Reflex.Dom.Builder.InputDisabled

37−import Reflex.Dom.Builder.Immediate (ImmediateDomBuilderT)

38+import Reflex.Dom.Builder.Immediate (GhcjsDomSpace, ImmediateDomBuilderT, runImmediateDomBuilderT, ImmediateDomBuilderEnv(..), SupportsImmediateDomBuilder, insertBefore, deleteBetweenExclusive)

38import Reflex.Dom.Builder.Hydration

39import Reflex.Dom.Builder.Hydration

39import Reflex.Dom.Builder.Static

40import Reflex.Dom.Builder.Static

40import Reflex.Host.Class

41import Reflex.Host.Class

42−type PrerenderClientConstraint js m =

43+type PrerenderClientConstraint' js m =

43 ( HasJS js m

44 ( HasJS js m

44 , HasJS js (Performable m)

45 , HasJS js (Performable m)

45 , MonadJSM m

46 , MonadJSM m

@@ -48,55 +49,60 @@ type PrerenderClientConstraint js m =

48 , HasJSContext (Performable m)

49 , HasJSContext (Performable m)

49 , MonadFix m

50 , MonadFix m

50 , MonadFix (Performable m)

51 , MonadFix (Performable m)

51−-- , DomBuilderSpace m ~ GhcjsDomSpace

52 )

54+type PrerenderClientConstraint js m =

55+ ( PrerenderClientConstraint' js m

56+ , DomBuilderSpace m ~ GhcjsDomSpace

57+ )

58+

54−class Monad m => Prerender js m | m -> js where

59+class Prerender js m | m -> js where

60+ type PrerenderServer m :: * -> *

61+ type PrerenderClient m :: * -> *

55− prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m))

62+ prerenderClientDict :: Either (PrerenderServer m a -> m a) (Dict (PrerenderClientConstraint js (PrerenderClient m)), PrerenderClient m a -> m a)

56− startPrerenderBlock :: m ()

63+ default prerenderClientDict :: forall n t a. (Prerender js n, MonadTrans t, m ~ t n, Monad n, Prerender js n, PrerenderServer m ~ PrerenderServer n, PrerenderClient m ~ PrerenderClient n)

57− default startPrerenderBlock :: (Prerender js n, m ~ t n, MonadTrans t, Monad n) => m ()

64+ => Either (PrerenderServer m a -> m a) (Dict (PrerenderClientConstraint js (PrerenderClient m)), PrerenderClient m a -> m a)

58− startPrerenderBlock = lift $ startPrerenderBlock

65+ prerenderClientDict = bimap (lift .) (\(Dict, f) -> (Dict, lift . f)) (prerenderClientDict :: Either (PrerenderServer n a -> n a) (Dict (PrerenderClientConstraint js (PrerenderClient n)), PrerenderClient n a -> n a))

59− endPrerenderBlock :: m ()

60− default endPrerenderBlock :: (Prerender js n, m ~ t n, MonadTrans t, Monad n) => m ()

61− endPrerenderBlock = lift $ endPrerenderBlock

63-- | Draw one widget when prerendering (e.g. server-side) and another when the

67-- | Draw one widget when prerendering (e.g. server-side) and another when the

64-- widget is fully instantiated. In a given execution of this function, there

68-- widget is fully instantiated. In a given execution of this function, there

65-- will be exactly one invocation of exactly one of the arguments.

69-- will be exactly one invocation of exactly one of the arguments.

66−prerender

67− :: forall js t m a. (Prerender js m, DomBuilder t m)

68− => m a -> (PrerenderClientConstraint js m => m a) -> m a

70+prerender :: forall js m a. Prerender js m => PrerenderServer m a -> (PrerenderClientConstraint js (PrerenderClient m) => PrerenderClient m a) -> m a

69−prerender server client = do

71+prerender server client = case prerenderClientDict of

70− startPrerenderBlock

71− a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of

72− Nothing -> server

72+ Left f -> f server

73− Just Dict -> client

73+ Right (Dict, f) -> f client

74− endPrerenderBlock

74+

75− pure a

76−

77−instance (PrerenderClientConstraint js m, ReflexHost t) => Prerender js (ImmediateDomBuilderT t m) where

75+instance (PrerenderClientConstraint' js m, ReflexHost t) => Prerender js (ImmediateDomBuilderT t m) where

78− prerenderClientDict = Just Dict

76+ type PrerenderServer (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m

79− startPrerenderBlock = return ()

77+ type PrerenderClient (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m

80− endPrerenderBlock = return ()

78+ prerenderClientDict = Right (Dict, id)

81−

79+

82−instance (PrerenderClientConstraint js m, ReflexHost t) => Prerender js (HydrationDomBuilderT t m) where

80+instance (PrerenderClientConstraint' js m, SupportsImmediateDomBuilder t m, ReflexHost t, PerformEvent t m) => Prerender js (HydrationDomBuilderT t m) where

83− prerenderClientDict = Just Dict

81+ type PrerenderServer (HydrationDomBuilderT t m) = HydrationDomBuilderT t m

84− startPrerenderBlock = do

82+ type PrerenderClient (HydrationDomBuilderT t m) = ImmediateDomBuilderT t m

85− depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth

83+ prerenderClientDict = Right $ (,) Dict $ \client -> do

86− d <- liftIO $ readIORef depth

84+ doc <- askDocument

87− when (d == 0) $ do

85+ unreadyChildren <- liftIO $ newIORef 0

86+ df <- Document.createDocumentFragment doc

87+ let env = ImmediateDomBuilderEnv

88+ { _immediateDomBuilderEnv_document = doc

89+ , _immediateDomBuilderEnv_parent = DOM.toNode df

90+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

91+ , _immediateDomBuilderEnv_commitAction = pure ()

92+ }

93+ events <- askEvents

94+ a <- lift $ runImmediateDomBuilderT client env events

95+ hydrateDOM $ DOM_Node $ do

88 -- Delete up to the end marker

96 -- Delete up to the end marker

89− hydrateDOM $ DOM_Node deleteToPrerenderEnd

97+ after <- deleteToPrerenderEnd

90− liftIO $ modifyIORef' depth succ

98+ insertBefore df after

91− endPrerenderBlock = do

99+ pure a

92− depth <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_prerenderDepth

93− liftIO $ modifyIORef' depth pred

100

95startMarker, endMarker :: IsString s => s

101startMarker, endMarker :: IsString s => s

96startMarker = "prerender/start"

102startMarker = "prerender/start"

97endMarker = "prerender/end"

103endMarker = "prerender/end"

104

99−deleteToPrerenderEnd :: (MonadIO m, MonadJSM m) => HydrationRunnerT t m ()

105+deleteToPrerenderEnd :: (MonadIO m, MonadJSM m) => HydrationRunnerT t m DOM.Element

100deleteToPrerenderEnd = do

106deleteToPrerenderEnd = do

101 depth <- liftIO $ newIORef 0

107 depth <- liftIO $ newIORef 0

102 ref <- getPreviousNode

108 ref <- getPreviousNode

@@ -120,34 +126,50 @@ deleteToPrerenderEnd = do

120 pure False

126 pure False

121 _ -> pure False

127 _ -> pure False

122 pure $ n == "SCRIPT" && attrCheck) DOM.Element

128 pure $ n == "SCRIPT" && attrCheck) DOM.Element

123− deleteBetweenInclusive startNode endNode

129+ deleteBetweenExclusive startNode endNode

124− setPreviousNode ref

130+ setPreviousNode $ Just $ DOM.toNode endNode -- TODO probably not necessary

131+ pure endNode

132+

133+data NoJavascript -- This type should never have a HasJS instance

125

134

126−data NoJavaScript -- This type should never have a HasJS instance

135+instance (js ~ NoJavascript, SupportsStaticDomBuilder t m) => Prerender js (StaticDomBuilderT t m) where

136+ type PrerenderServer (StaticDomBuilderT t m) = StaticDomBuilderT t m

137+ type PrerenderClient (StaticDomBuilderT t m) = StaticDomBuilderT t m

138+ prerenderClientDict = Left $ \server -> do

139+ -- We must put markers around the prerendered parts because we don't

140+ -- run the 'server' widget on the frontend: thus we have no idea how many

141+ -- nodes should be replaced when we are hydrating

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

143+ a <- server

144+ _ <- element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()

145+ pure a

127

146

128−instance (Monad m, js ~ NoJavaScript, Adjustable t m, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ IORef) => Prerender js (StaticDomBuilderT t m) where

129− prerenderClientDict = Nothing

130− startPrerenderBlock = void $ element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()

131− endPrerenderBlock = void $ element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()

132

147

148+instance (Monad m, Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where

149+ type PrerenderServer (PostBuildT t m) = PrerenderServer m

150+ type PrerenderClient (PostBuildT t m) = PrerenderClient m

133

151

134−instance (Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where

152+instance (Monad m, Prerender js m) => Prerender js (DynamicWriterT t w m) where

135− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

153+ type PrerenderServer (DynamicWriterT t w m) = PrerenderServer m

154+ type PrerenderClient (DynamicWriterT t w m) = PrerenderClient m

136

155

137−instance Prerender js m => Prerender js (DynamicWriterT t w m) where

156+instance (Monad m, Prerender js m) => Prerender js (EventWriterT t w m) where

138− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

157+ type PrerenderServer (EventWriterT t w m) = PrerenderServer m

158+ type PrerenderClient (EventWriterT t w m) = PrerenderClient m

139

159

140−instance Prerender js m => Prerender js (EventWriterT t w m) where

160+instance (Monad m, Prerender js m) => Prerender js (ReaderT w m) where

141− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

161+ type PrerenderServer (ReaderT w m) = PrerenderServer m

162+ type PrerenderClient (ReaderT w m) = PrerenderClient m

142

163

143−instance Prerender js m => Prerender js (ReaderT w m) where

164+instance (Monad m, Prerender js m) => Prerender js (RequesterT t request response m) where

144− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

165+ type PrerenderServer (RequesterT t request response m) = PrerenderServer m

166+ type PrerenderClient (RequesterT t request response m) = PrerenderClient m

145

167

146−instance Prerender js m => Prerender js (RequesterT t request response m) where

168+instance (Monad m, Prerender js m) => Prerender js (QueryT t q m) where

147− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

169+ type PrerenderServer (QueryT t q m) = PrerenderServer m

170+ type PrerenderClient (QueryT t q m) = PrerenderClient m

148

171

149−instance Prerender js m => Prerender js (QueryT t q m) where

172+instance (Monad m, Prerender js m) => Prerender js (InputDisabledT m) where

150− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

173+ type PrerenderServer (InputDisabledT m) = PrerenderServer m

174+ type PrerenderClient (InputDisabledT m) = PrerenderClient m

151

175

152−instance Prerender js m => Prerender js (InputDisabledT m) where

153− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))