@@ -15,6 +15,7 @@
15module Reflex.Dom.Prerender
15module Reflex.Dom.Prerender
16 ( Prerender (..)
16 ( Prerender (..)
17 , prerender
17 , prerender
18+ , PrerenderClientConstraint
20import Control.Lens ((&), (.~))
21import Control.Lens ((&), (.~))
@@ -23,7 +24,7 @@ import Control.Monad.Ref (Ref, MonadRef)
23import Data.Bifunctor (bimap)
24import Data.Bifunctor (bimap)
24import Data.Constraint
25import Data.Constraint
25import Data.Default
26import Data.Default
26−import Data.IORef (modifyIORef', readIORef, newIORef)
27+import Data.IORef (modifyIORef', readIORef, newIORef, writeIORef)
27import Data.String (IsString)
28import Data.String (IsString)
28import qualified GHCJS.DOM.Element as Element
29import qualified GHCJS.DOM.Element as Element
29import qualified GHCJS.DOM.Types as DOM
30import qualified GHCJS.DOM.Types as DOM
@@ -57,46 +58,45 @@ type PrerenderClientConstraint js m =
59class Prerender js m | m -> js where
60class 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)
61+ prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js 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)
62+ prerenderWrapper :: m (m ())
64− => Either (PrerenderServer m a -> m a) (Dict (PrerenderClientConstraint js (PrerenderClient m)), PrerenderClient m a -> m a)
63+ default prerenderWrapper :: (MonadTrans t, Monad n, m ~ t n, Prerender js n) => m (m ())
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))
64+ prerenderWrapper = lift $ lift <$> prerenderWrapper
67-- | Draw one widget when prerendering (e.g. server-side) and another when the
66-- | Draw one widget when prerendering (e.g. server-side) and another when the
68-- widget is fully instantiated. In a given execution of this function, there
67-- widget is fully instantiated. In a given execution of this function, there
69-- will be exactly one invocation of exactly one of the arguments.
68-- 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
69+prerender :: forall js m a. (Prerender js m, Monad m) => m a -> (PrerenderClientConstraint js m => m a) -> m a
71−prerender server client = case prerenderClientDict of
70+prerender server client = do
71+ finalize <- prerenderWrapper
72+ a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
72− Left f -> f server
73+ Nothing -> server
73− Right (Dict, f) -> f client
74+ Just Dict -> client
75instance (PrerenderClientConstraint' js m, ReflexHost t) => Prerender js (ImmediateDomBuilderT t m) where
78instance (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 ())
80instance (PrerenderClientConstraint' js m, SupportsImmediateDomBuilder t m, ReflexHost t, PerformEvent t m) => Prerender js (HydrationDomBuilderT t m) where
82instance (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
83+ prerenderClientDict = Just Dict
84− doc <- askDocument
84+ prerenderWrapper = do
85− unreadyChildren <- liftIO $ newIORef 0
85+ parent <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
86+ hydrationMode <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationMode
86− df <- Document.createDocumentFragment doc
87+ df <- Document.createDocumentFragment =<< askDocument
87− let env = ImmediateDomBuilderEnv
88+ initialParent <- liftIO $ readIORef parent
88− { _immediateDomBuilderEnv_document = doc
89+ initialHydrationMode <- liftIO $ readIORef hydrationMode
89− , _immediateDomBuilderEnv_parent = DOM.toNode df
90+ liftIO $ writeIORef parent $ DOM.toNode df
90− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
91+ liftIO $ writeIORef hydrationMode HydrationMode_Immediate
91− , _immediateDomBuilderEnv_commitAction = pure ()
92+ pure $ do
92− }
93+ liftIO $ writeIORef parent initialParent
93− events <- askEvents
94+ liftIO $ writeIORef hydrationMode initialHydrationMode
94− a <- lift $ runImmediateDomBuilderT client env events
95− addHydrationStep $ do
95+ addHydrationStep $ do
96+ liftIO $ putStrLn "Hydration step"
96− -- Delete up to the end marker
97+ -- Delete up to the end marker
97− after <- deleteToPrerenderEnd
98+ after <- deleteToPrerenderEnd
98− insertBefore df after
99+ insertBefore df after
101startMarker, endMarker :: IsString s => s
101startMarker, endMarker :: IsString s => s
102startMarker = "prerender/start"
102startMarker = "prerender/start"
@@ -133,43 +133,29 @@ deleteToPrerenderEnd = do
133data NoJavascript -- This type should never have a HasJS instance
133data NoJavascript -- This type should never have a HasJS instance
135instance (js ~ NoJavascript, SupportsStaticDomBuilder t m) => Prerender js (StaticDomBuilderT t m) where
135instance (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
136+ prerenderClientDict = Nothing
139− -- We must put markers around the prerendered parts because we don't
137+ prerenderWrapper = do
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 ()
138 _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()
144− _ <- element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
139+ pure $ void $ element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
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)))
148−instance (Monad m, Prerender js m, ReflexHost t) => Prerender js (PostBuildT t m) where
144+instance (Prerender js m, Monad m) => Prerender js (DynamicWriterT t w m) where
149− type PrerenderServer (PostBuildT t m) = PrerenderServer m
145+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
150− type PrerenderClient (PostBuildT t m) = PrerenderClient m
152−instance (Monad m, Prerender js m) => Prerender js (DynamicWriterT t w m) where
147+instance (Prerender js m, Monad m) => Prerender js (EventWriterT t w m) where
153− type PrerenderServer (DynamicWriterT t w m) = PrerenderServer m
148+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
154− type PrerenderClient (DynamicWriterT t w m) = PrerenderClient m
156−instance (Monad m, Prerender js m) => Prerender js (EventWriterT t w m) where
150+instance (Prerender js m, Monad m) => Prerender js (ReaderT w m) where
157− type PrerenderServer (EventWriterT t w m) = PrerenderServer m
151+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
158− type PrerenderClient (EventWriterT t w m) = PrerenderClient m
160−instance (Monad m, Prerender js m) => Prerender js (ReaderT w m) where
153+instance (Prerender js m, Monad m) => Prerender js (RequesterT t request response m) where
161− type PrerenderServer (ReaderT w m) = PrerenderServer m
154+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
162− type PrerenderClient (ReaderT w m) = PrerenderClient m
164−instance (Monad m, Prerender js m) => Prerender js (RequesterT t request response m) where
156+instance (Prerender js m, Monad m) => Prerender js (QueryT t q m) where
165− type PrerenderServer (RequesterT t request response m) = PrerenderServer m
157+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
166− type PrerenderClient (RequesterT t request response m) = PrerenderClient m
168−instance (Monad m, Prerender js m) => Prerender js (QueryT t q m) where
159+instance (Prerender js m, Monad m) => Prerender js (InputDisabledT m) where
169− type PrerenderServer (QueryT t q m) = PrerenderServer m
160+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
170− type PrerenderClient (QueryT t q m) = PrerenderClient m
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