@@ -15,6 +15,7 @@
1515module Reflex.Dom.Prerender
1616 ( Prerender (..)
1717 , prerender
18+ , PrerenderClientConstraint
1819 ) where
1920
2021import Control.Lens ((&), (.~))
@@ -23,7 +24,7 @@ import Control.Monad.Ref (Ref, MonadRef)
2324import Data.Bifunctor (bimap)
2425import Data.Constraint
2526import Data.Default
26−import Data.IORef (modifyIORef', readIORef, newIORef)
27+import Data.IORef (modifyIORef', readIORef, newIORef, writeIORef)
2728import Data.String (IsString)
2829import qualified GHCJS.DOM.Element as Element
2930import qualified GHCJS.DOM.Types as DOM
@@ -57,46 +58,45 @@ type PrerenderClientConstraint js m =
5758 )
5859
5960class Prerender js m | m -> js where
60− type PrerenderServer m :: * -> *
61− type PrerenderClient m :: * -> *
62− prerenderClientDict :: Either (PrerenderServer m a -> m a) (Dict (PrerenderClientConstraint js (PrerenderClient m)), PrerenderClient m a -> m a)
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)
64− => Either (PrerenderServer m a -> m a) (Dict (PrerenderClientConstraint js (PrerenderClient m)), PrerenderClient m a -> m a)
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))
61+ prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m))
62+ prerenderWrapper :: m (m ())
63+ default prerenderWrapper :: (MonadTrans t, Monad n, m ~ t n, Prerender js n) => m (m ())
64+ prerenderWrapper = lift $ lift <$> prerenderWrapper
6665
6766-- | Draw one widget when prerendering (e.g. server-side) and another when the
6867-- widget is fully instantiated. In a given execution of this function, there
6968-- will be exactly one invocation of exactly one of the arguments.
70−prerender :: forall js m a. Prerender js m => PrerenderServer m a -> (PrerenderClientConstraint js (PrerenderClient m) => PrerenderClient m a) -> m a
71−prerender server client = case prerenderClientDict of
72− Left f -> f server
73− Right (Dict, f) -> f client
69+prerender :: forall js m a. (Prerender js m, Monad m) => m a -> (PrerenderClientConstraint js m => m a) -> m a
70+prerender server client = do
71+ finalize <- prerenderWrapper
72+ a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
73+ Nothing -> server
74+ Just Dict -> client
75+ finalize
76+ pure a
7477
7578instance (PrerenderClientConstraint' js m, ReflexHost t) => Prerender js (ImmediateDomBuilderT t m) where
76− type PrerenderServer (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m
77− type PrerenderClient (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m
78− prerenderClientDict = Right (Dict, id)
79+ prerenderClientDict = Just Dict
80+ prerenderWrapper = pure (pure ())
7981
8082instance (PrerenderClientConstraint' js m, SupportsImmediateDomBuilder t m, ReflexHost t, PerformEvent t m) => Prerender js (HydrationDomBuilderT t m) where
81− type PrerenderServer (HydrationDomBuilderT t m) = HydrationDomBuilderT t m
82− type PrerenderClient (HydrationDomBuilderT t m) = ImmediateDomBuilderT t m
83− prerenderClientDict = Right $ (,) Dict $ \client -> do
84− doc <- askDocument
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− addHydrationStep $ do
96− -- Delete up to the end marker
97− after <- deleteToPrerenderEnd
98− insertBefore df after
99− pure a
83+ prerenderClientDict = Just Dict
84+ prerenderWrapper = do
85+ parent <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
86+ hydrationMode <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationMode
87+ df <- Document.createDocumentFragment =<< askDocument
88+ initialParent <- liftIO $ readIORef parent
89+ initialHydrationMode <- liftIO $ readIORef hydrationMode
90+ liftIO $ writeIORef parent $ DOM.toNode df
91+ liftIO $ writeIORef hydrationMode HydrationMode_Immediate
92+ pure $ do
93+ liftIO $ writeIORef parent initialParent
94+ liftIO $ writeIORef hydrationMode initialHydrationMode
95+ addHydrationStep $ do
96+ liftIO $ putStrLn "Hydration step"
97+ -- Delete up to the end marker
98+ after <- deleteToPrerenderEnd
99+ insertBefore df after
100100
101101startMarker, endMarker :: IsString s => s
102102startMarker = "prerender/start"
@@ -133,43 +133,29 @@ deleteToPrerenderEnd = do
133133data NoJavascript -- This type should never have a HasJS instance
134134
135135instance (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
136+ prerenderClientDict = Nothing
137+ prerenderWrapper = do
142138 _ <- 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
139+ pure $ void $ element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
146140
141+instance (Prerender js m, Monad m, ReflexHost t) => Prerender js (PostBuildT t m) where
142+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
147143
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
144+instance (Prerender js m, Monad m) => Prerender js (DynamicWriterT t w m) where
145+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
151146
152−instance (Monad m, Prerender js m) => Prerender js (DynamicWriterT t w m) where
153− type PrerenderServer (DynamicWriterT t w m) = PrerenderServer m
154− type PrerenderClient (DynamicWriterT t w m) = PrerenderClient m
147+instance (Prerender js m, Monad m) => Prerender js (EventWriterT t w m) where
148+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
155149
156−instance (Monad m, Prerender js m) => Prerender js (EventWriterT t w m) where
157− type PrerenderServer (EventWriterT t w m) = PrerenderServer m
158− type PrerenderClient (EventWriterT t w m) = PrerenderClient m
150+instance (Prerender js m, Monad m) => Prerender js (ReaderT w m) where
151+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
159152
160−instance (Monad m, Prerender js m) => Prerender js (ReaderT w m) where
161− type PrerenderServer (ReaderT w m) = PrerenderServer m
162− type PrerenderClient (ReaderT w m) = PrerenderClient m
153+instance (Prerender js m, Monad m) => Prerender js (RequesterT t request response m) where
154+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
163155
164−instance (Monad m, Prerender js m) => Prerender js (RequesterT t request response m) where
165− type PrerenderServer (RequesterT t request response m) = PrerenderServer m
166− type PrerenderClient (RequesterT t request response m) = PrerenderClient m
156+instance (Prerender js m, Monad m) => Prerender js (QueryT t q m) where
157+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
167158
168−instance (Monad m, Prerender js m) => Prerender js (QueryT t q m) where
169− type PrerenderServer (QueryT t q m) = PrerenderServer m
170− type PrerenderClient (QueryT t q m) = PrerenderClient m
171−
172−instance (Monad m, Prerender js m) => Prerender js (InputDisabledT m) where
173− type PrerenderServer (InputDisabledT m) = PrerenderServer m
174− type PrerenderClient (InputDisabledT m) = PrerenderClient m
159+instance (Prerender js m, Monad m) => Prerender js (InputDisabledT m) where
160+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
175161