Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

WIP: Use runHostWithIO #312

Open
wants to merge 1 commit into
base: develop
Choose a base branch
from
Open

WIP: Use runHostWithIO #312

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
62 changes: 34 additions & 28 deletions reflex-dom-core/src/Reflex/Dom/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,7 @@ import Reflex.Class
import Reflex.Dom.Builder.Immediate
import Reflex.Dom.Class
import Reflex.Host.Class
import Reflex.Main
import Reflex.PerformEvent.Base
import Reflex.PostBuild.Base
import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
Expand Down Expand Up @@ -86,30 +87,31 @@ attachHydrationWidget
-> IORef HydrationMode
-> Maybe (IORef [(Node, HydrationRunnerT DomTimeline (DomCoreWidget ()) ())])
-> EventChannel
-> PerformEventT DomTimeline DomHost (a, IORef (Maybe (EventTrigger DomTimeline ())))
-> PostBuildT DomTimeline (PerformEventT DomTimeline DomHost) a
)
-> IO (a, FireCommand DomTimeline DomHost)
-> IO a
attachHydrationWidget switchoverAction jsSing w = do
hydrationMode <- liftIO $ newIORef HydrationMode_Hydrating
rootNodesRef <- liftIO $ newIORef []
events <- newChan
runDomHost $ flip runTriggerEventT events $ mdo
(result, _, _) <- runHostWithIO events runDomHost runDomHost $ flip runTriggerEventT events $ mdo
(syncEvent, fireSync) <- newTriggerEvent
((result, postBuildTriggerRef), fc@(FireCommand fire)) <- lift $ hostPerformEventT $ do
a <- w syncEvent hydrationMode (Just rootNodesRef) events
_ <- runWithReplace (return ()) $ delayedAction <$ syncEvent
pure a
mPostBuildTrigger <- readRef postBuildTriggerRef
lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

result <- lift $ w syncEvent hydrationMode (Just rootNodesRef) events
_ <- lift $ runWithReplace (return ()) $ delayedAction <$ syncEvent

liftIO $ fireSync ()
rootNodes <- liftIO $ readIORef rootNodesRef
let delayedAction = do
let delayedAction :: PostBuildT DomTimeline (PerformEventT DomTimeline DomHost) ()
delayedAction = do
for_ (reverse rootNodes) $ \(rootNode, runner) -> do
let hydrate = runHydrationRunnerT runner Nothing rootNode events
void $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing
-- Should this be lift, or distributeJSContextSingleton? Why do we use never?
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could someone help me out with this?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hmm iirc the PostBuildT shouldn't really be here, but it was fairly awkward to get rid of it

void $ lift $ runWithJSContextSingleton (runPostBuildT hydrate never) jsSing
liftIO $ writeIORef hydrationMode HydrationMode_Immediate
runWithJSContextSingleton (DOM.liftJSM switchoverAction) jsSing
pure (result, fc)
pure result
pure result

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

Expand All @@ -130,8 +132,7 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM
globalDoc <- currentDocumentUnchecked
headElement <- getHeadUnchecked globalDoc
bodyElement <- getBodyUnchecked globalDoc
(events, fc) <- liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
liftIO . attachHydrationWidget switchoverAction jsSing $ \switchover hydrationMode hydrationResult events -> do
let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
hydrateDom n w = do
delayed <- liftIO $ newIORef $ pure ()
Expand All @@ -151,9 +152,7 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM
res <- liftIO $ readIORef delayed
liftIO $ modifyIORef' hr ((n, res) :)
pure a
runWithJSContextSingleton (runPostBuildT (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events) postBuild) jsSing
return (events, postBuildTriggerRef)
liftIO $ processAsyncEvents events fc
runWithJSContextSingleton (distributeJSContextSingleton (runTriggerEventT (app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)) events)) jsSing

{-# INLINE mainWidget #-}
mainWidget :: (forall x. Widget x ()) -> JSM ()
Expand Down Expand Up @@ -221,10 +220,10 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
bodyElement <- getBodyUnchecked doc
bodyFragment <- createDocumentFragment doc
hydrationMode <- liftIO $ newIORef HydrationMode_Immediate
(events, fc) <- liftIO . attachWidget'' $ \events -> do
events <- liftIO newChan
_ <- liftIO . runHostWithIO events runDomHost runDomHost $ do
let (headWidget, bodyWidget) = widgets
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT DomTimeline DomHost c
let go :: forall c. Widget () c -> DOM.DocumentFragment -> PostBuildT DomTimeline (PerformEventT DomTimeline DomHost) c
go w df = do
unreadyChildren <- liftIO $ newIORef 0
delayed <- liftIO $ newIORef $ pure ()
Expand All @@ -237,13 +236,20 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
, _hydrationDomBuilderEnv_delayed = delayed
, _hydrationDomBuilderEnv_hydrationMode = hydrationMode
}
runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing
runWithJSContextSingleton (distributeJSContextSingleton (runHydrationDomBuilderT w builderEnv events)) jsSing
rec b <- go (headWidget a) headFragment
a <- go (bodyWidget b) bodyFragment
return (events, postBuildTriggerRef)
return ()
replaceElementContents headElement headFragment
replaceElementContents bodyElement bodyFragment
liftIO $ processAsyncEvents events fc

distributeJSContextSingleton
:: PostBuildT t (WithJSContextSingleton x m) a
-> WithJSContextSingleton x (PostBuildT t m) a
distributeJSContextSingleton (PostBuildT (ReaderT x)) =
WithJSContextSingleton $ ReaderT $ \j ->
PostBuildT $ ReaderT $ \p -> runReaderT (unWithJSContextSingleton (x p)) j


replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> JSM ()
replaceElementContents e df = do
Expand All @@ -257,8 +263,8 @@ attachWidget' rootElement jsSing w = do
doc <- getOwnerDocumentUnchecked rootElement
df <- createDocumentFragment doc
hydrationMode <- liftIO $ newIORef HydrationMode_Immediate
((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
events <- liftIO newChan
(a, fc, _) <- liftIO . runHostWithIO events runDomHost runDomHost $ do
unreadyChildren <- liftIO $ newIORef 0
delayed <- liftIO $ newIORef $ pure ()
let builderEnv = HydrationDomBuilderEnv
Expand All @@ -270,10 +276,9 @@ attachWidget' rootElement jsSing w = do
, _hydrationDomBuilderEnv_delayed = delayed
, _hydrationDomBuilderEnv_hydrationMode = hydrationMode
}
a <- runWithJSContextSingleton (runPostBuildT (runHydrationDomBuilderT w builderEnv events) postBuild) jsSing
return ((a, events), postBuildTriggerRef)
a <- runWithJSContextSingleton (distributeJSContextSingleton (runHydrationDomBuilderT w builderEnv events)) jsSing
return a
replaceElementContents rootElement df
liftIO $ processAsyncEvents events fc
return (a, fc)

type EventChannel = Chan [DSum (EventTriggerRef DomTimeline) TriggerInvocation]
Expand All @@ -288,6 +293,7 @@ attachWidget'' w = do
forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
return (result, fc)

{-# DEPRECATED processAsyncEvents "Use runHostWithIO" #-}
processAsyncEvents :: EventChannel -> FireCommand DomTimeline DomHost -> IO ()
processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
ers <- readChan events
Expand Down