@@ -6,6 +6,7 @@
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE Rank2Types #-}
9+{-# LANGUAGE RecursiveDo #-}
910{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE TypeFamilies #-}
1112{-# LANGUAGE TypeSynonymInstances #-}
@@ -14,7 +15,6 @@
1415-- | Render the first widget on the server, and the second on the client.
1516module Reflex.Dom.Prerender
1617 ( Prerender (..)
17− , prerender
1818 , prerender_
1919 , PrerenderClientConstraint
2020 , PrerenderBaseConstraints
@@ -23,8 +23,6 @@ module Reflex.Dom.Prerender
2323import Control.Monad.Primitive (PrimMonad)
2424import Control.Monad.Reader
2525import Control.Monad.Ref (MonadRef(..))
26−import Control.Monad.State.Strict
27−import Data.Foldable (traverse_)
2826import Data.IORef (IORef, newIORef)
2927import Data.Text (Text)
3028import Foreign.JavaScript.TH
@@ -67,40 +65,32 @@ type PrerenderBaseConstraints t m =
6765 , Ref m ~ IORef
6866 )
6967
70−-- | Render the first widget on the server, and the second on the client. The
71−-- hydration builder will run *both* widgets, updating the result dynamic at
72−-- switchover time.
73−prerender
74− :: (Functor m, Prerender t m)
75− => m a -> ((PrerenderClientConstraint t (Client m)) => Client m a) -> m (Dynamic t a)
76−prerender server client = snd <$> prerenderImpl ((,) () <$> server) client
77−
7868-- | Render the first widget on the server, and the second on the client. The
7969-- hydration builder will run *both* widgets.
8070prerender_
8171 :: (Functor m, Reflex t, Prerender t m)
8272 => m () -> ((PrerenderClientConstraint t (Client m)) => Client m ()) -> m ()
83−prerender_ server client = void $ prerenderImpl ((,) () <$> server) client
73+prerender_ server client = void $ prerender server client
8474
8575class Prerender t m | m -> t where
8676 -- | Monad in which the client widget is built
8777 type Client m :: * -> *
88− -- | This function should be considered internal: it should only be used where
89− -- the resultant 'Maybe' isn't used to change what is built in the DOM, or
90− -- hydration will fail.
91− prerenderImpl :: m (a, b) -> ((PrerenderClientConstraint t (Client m)) => Client m b) -> m (Maybe a, Dynamic t b)
78+ -- | Render the first widget on the server, and the second on the client. The
79+ -- hydration builder will run *both* widgets, updating the result dynamic at
80+ -- switchover time.
81+ prerender :: m a -> ((PrerenderClientConstraint t (Client m)) => Client m a) -> m (Dynamic t a)
9282
9383instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (HydrationDomBuilderT GhcjsDomSpace t m) where
9484 type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m
95− prerenderImpl _ client = (,) Nothing . pure <$> client
85+ prerender _ client = pure <$> client
9686
9787instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT HydrationDomSpace t m) where
9888 -- | PostBuildT is needed here because we delay running the client builder
9989 -- until after switchover, at which point the postBuild of @m@ has already fired
100− type Client (HydrationDomBuilderT HydrationDomSpace t m) = PostBuildT t (HydrationDomBuilderT GhcjsDomSpace t m) -- PostBuildT t (ImmediateDomBuilderT t m)
90+ type Client (HydrationDomBuilderT HydrationDomSpace t m) = PostBuildT t (HydrationDomBuilderT GhcjsDomSpace t m)
10191 -- | Runs the server widget up until switchover, then replaces it with the
10292 -- client widget.
103− prerenderImpl server client = do
93+ prerender server client = do
10494 env <- HydrationDomBuilderT ask
10595 events <- askEvents
10696 doc <- askDocument
@@ -117,64 +107,77 @@ instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerend
117107 , _hydrationDomBuilderEnv_hydrationMode = hydrationMode
118108 , _hydrationDomBuilderEnv_switchover = never
119109 }
120− (a, b0) <- lift $ runHydrationDomBuilderT server (env { _hydrationDomBuilderEnv_delayed = delayed }) events
121− (b', trigger) <- newTriggerEvent
110+ a0 <- lift $ runHydrationDomBuilderT server (env { _hydrationDomBuilderEnv_delayed = delayed }) events
111+ (a', trigger) <- newTriggerEvent
122112 getHydrationMode >>= \case
123113 HydrationMode_Immediate -> do
124− liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void b') env' events
114+ liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void a') env' events
125115 append $ DOM.toNode df
126116 HydrationMode_Hydrating -> addHydrationStep $ do
127− liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void b') env' events
117+ liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void a') env' events
128118 insertBefore df =<< deleteToPrerenderEnd doc
129− (,) (Just a) <$> holdDyn b0 b'
119+ holdDyn a0 a'
130120
131121instance SupportsStaticDomBuilder t m => Prerender t (StaticDomBuilderT t m) where
132122 type Client (StaticDomBuilderT t m) = HydrationDomBuilderT GhcjsDomSpace t m
133− prerenderImpl server _ = do
123+ prerender server _ = do
134124 _ <- commentNode $ CommentNodeConfig startMarker Nothing
135− (a, b) <- server
125+ a <- server
136126 _ <- commentNode $ CommentNodeConfig endMarker Nothing
137− pure (Just a, pure b)
127+ pure $ pure a
138128
139129instance (Prerender t m, Monad m) => Prerender t (ReaderT r m) where
140− type Client (ReaderT r m) = Client m
141− prerenderImpl server client = do
130+ type Client (ReaderT r m) = ReaderT r (Client m)
131+ prerender server client = do
142132 r <- ask
143− lift $ prerenderImpl (runReaderT server r) client
144−
145−instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (StateT s m) where
146− type Client (StateT s m) = Client m
147− prerenderImpl server client = do
148− s <- get
149− (ma, evt) <- lift $ prerenderImpl
150− (do ((a, b), s') <- runStateT server s; pure ((a, s'), b))
151− client
152− traverse_ (put . snd) ma
153− pure (fst <$> ma, evt)
154−
155−instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (DynamicWriterT t w m) where
156− type Client (DynamicWriterT t w m) = Client m
157− prerenderImpl (DynamicWriterT server) client = DynamicWriterT $ prerenderImpl server client
158−
159−instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (EventWriterT t w m) where
160− type Client (EventWriterT t w m) = Client m
161− prerenderImpl (EventWriterT server) client = EventWriterT $ prerenderImpl server client
162−
163−instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (RequesterT t request response m) where
164− type Client (RequesterT t request response m) = Client m
165− prerenderImpl (RequesterT server) client = RequesterT $ prerenderImpl server client
166−
167−instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (QueryT t q m) where
168− type Client (QueryT t q m) = Client m
169− prerenderImpl (QueryT server) client = QueryT $ prerenderImpl server client
133+ lift $ prerender (runReaderT server r) (runReaderT client r)
134+
135+instance (Prerender t m, Monad m, Reflex t, MonadFix m, Monoid w) => Prerender t (DynamicWriterT t w m) where
136+ type Client (DynamicWriterT t w m) = DynamicWriterT t w (Client m)
137+ prerender server client = do
138+ x <- lift $ prerender (runDynamicWriterT server) (runDynamicWriterT client)
139+ let (a, w') = splitDynPure x
140+ w = join w'
141+ tellDyn w
142+ pure a
143+
144+instance (Prerender t m, Monad m, Reflex t, Semigroup w) => Prerender t (EventWriterT t w m) where
145+ type Client (EventWriterT t w m) = EventWriterT t w (Client m)
146+ prerender server client = do
147+ x <- lift $ prerender (runEventWriterT server) (runEventWriterT client)
148+ let (a, w') = splitDynPure x
149+ w = switch $ current w'
150+ tellEvent w
151+ pure a
152+
153+-- TODO
154+--instance (Prerender t m, Monad m) => Prerender t (RequesterT t request response m) where
155+-- type Client (RequesterT t request response m) = RequesterT t request response (Client m)
156+-- prerender server client = mdo
157+-- response :: Event t (RequesterData response) <- requesting request
158+-- x <- lift $ prerender (runRequesterT server response) (runRequesterT client response)
159+-- let (a, request') = splitDynPure x
160+-- request = switch $ current request' :: Event t (RequesterData request)
161+-- pure a
162+
163+instance (Prerender t m, Monad m, Reflex t, MonadFix m, Group q, Additive q, Query q) => Prerender t (QueryT t q m) where
164+ type Client (QueryT t q m) = QueryT t q (Client m)
165+ prerender server client = mdo
166+ result <- queryDyn query
167+ x <- lift $ prerender (runQueryT server result) (runQueryT client result)
168+ let (a, inc) = splitDynPure x
169+ query = incrementalToDynamic =<< inc -- Can we avoid the incrementalToDynamic?
170+ pure a
170171
171172instance (Prerender t m, Monad m) => Prerender t (InputDisabledT m) where
172173 type Client (InputDisabledT m) = Client m
173− prerenderImpl (InputDisabledT server) client = InputDisabledT $ prerenderImpl server client
174+ prerender (InputDisabledT server) client = InputDisabledT $ prerender server client
174175
175−instance (Prerender t m, Monad m) => Prerender t (PostBuildT t m) where
176− type Client (PostBuildT t m) = Client m
177− prerenderImpl (PostBuildT server) client = PostBuildT $ prerenderImpl server client
176+instance (Prerender t m, Monad m, ReflexHost t) => Prerender t (PostBuildT t m) where
177+ type Client (PostBuildT t m) = PostBuildT t (Client m)
178+ prerender server client = PostBuildT $ do
179+ pb <- ask
180+ lift $ prerender (runPostBuildT server pb) (runPostBuildT client pb)
178181
179182startMarker, endMarker :: Text
180183startMarker = "prerender/start"