@@ -9,20 +9,27 @@
99{-# LANGUAGE MultiParamTypeClasses #-}
1010{-# LANGUAGE Rank2Types #-}
1111{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
1213{-# LANGUAGE TypeFamilies #-}
1314{-# LANGUAGE TypeSynonymInstances #-}
1415{-# LANGUAGE UndecidableInstances #-}
16+
17+-- | Render the first widget on the server, and the second on the client.
1518module Reflex.Dom.Prerender
1619 ( Prerender (..)
1720 , prerender
21+ , prerender_
1822 , PrerenderClientConstraint
1923 ) where
2024
2125import Control.Lens ((&), (.~))
26+import Control.Monad.Primitive (PrimMonad)
2227import Control.Monad.Reader
23−import Data.Constraint
28+import Control.Monad.Ref (MonadRef(..))
29+import Control.Monad.State.Strict
2430import Data.Default
25−import Data.IORef (modifyIORef', readIORef, newIORef, writeIORef)
31+import Data.Foldable (traverse_)
32+import Data.IORef (IORef, modifyIORef', readIORef, newIORef)
2633import Data.String (IsString)
2734import qualified GHCJS.DOM.Element as Element
2835import qualified GHCJS.DOM.Types as DOM
@@ -33,67 +40,137 @@ import GHCJS.DOM.Types (MonadJSM)
3340import Reflex hiding (askEvents)
3441import Reflex.Dom.Builder.Class
3542import Reflex.Dom.Builder.InputDisabled
36−import Reflex.Dom.Builder.Immediate (GhcjsDomSpace, ImmediateDomBuilderT, SupportsImmediateDomBuilder, insertBefore, deleteBetweenExclusive)
43+import Reflex.Dom.Builder.Immediate (ImmediateDomBuilderT, SupportsImmediateDomBuilder, insertBefore, deleteBetweenExclusive, runImmediateDomBuilderT, ImmediateDomBuilderEnv(..), GhcjsDomSpace)
3744import Reflex.Dom.Builder.Hydration
3845import Reflex.Dom.Builder.Static
3946import Reflex.Host.Class
4047
41−type PrerenderClientConstraint' js m =
42− ( HasJS js m
43− , HasJS js (Performable m)
44− , MonadJSM m
45− , MonadJSM (Performable m)
46− , HasJSContext m
47− , HasJSContext (Performable m)
48− , MonadFix m
49− , MonadFix (Performable m)
48+type PrerenderClientConstraint t m =
49+ ( DomBuilder t m
50+ , DomBuilderSpace m ~ GhcjsDomSpace
51+ , HasDocument m
52+ , TriggerEvent t m
53+ , Prerender t m
54+ , PrerenderBaseConstraints t m
5055 )
5156
52−type PrerenderClientConstraint js m =
53− ( PrerenderClientConstraint' js m
54− , DomBuilderSpace m ~ GhcjsDomSpace
57+type PrerenderBaseConstraints t m =
58+ ( HasJSContext (Performable m)
59+ , HasJSContext m
60+ , MonadFix m
61+ , MonadHold t m
62+ , MonadJSM (Performable m)
63+ , MonadJSM m
64+ , MonadRef (Performable m)
65+ , MonadRef m
66+ , MonadReflexCreateTrigger t m
67+ , MonadSample t (Performable m)
68+ , PerformEvent t m
69+ , PostBuild t m
70+ , PrimMonad m
71+ , Ref (Performable m) ~ IORef
72+ , Ref m ~ IORef
5573 )
5674
57−class Prerender js m | m -> js where
58− prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m))
59− prerenderWrapper :: m (m ())
60− default prerenderWrapper :: (MonadTrans t, Monad n, m ~ t n, Prerender js n) => m (m ())
61− prerenderWrapper = lift $ lift <$> prerenderWrapper
62−
63−-- | 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
65−-- will be exactly one invocation of exactly one of the arguments.
66−prerender :: forall js m a. (Prerender js m, Monad m) => m a -> (PrerenderClientConstraint js m => m a) -> m a
67−prerender server client = do
68− finalize <- prerenderWrapper
69− a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
70− Nothing -> server
71− Just Dict -> client
72− finalize
73− pure a
74−
75−instance (PrerenderClientConstraint' js m, ReflexHost t) => Prerender js (ImmediateDomBuilderT t m) where
76− prerenderClientDict = Just Dict
77− prerenderWrapper = pure (pure ())
78−
79−instance (PrerenderClientConstraint' js m, SupportsImmediateDomBuilder t m, ReflexHost t, PerformEvent t m) => Prerender js (HydrationDomBuilderT t m) where
80− prerenderClientDict = Just Dict
81− prerenderWrapper = getHydrationMode >>= \case
82− HydrationMode_Immediate -> pure (pure ())
83− HydrationMode_Hydrating -> do
84− parent <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
85− hydrationMode <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationMode
86− df <- Document.createDocumentFragment =<< askDocument
87− initialParent <- liftIO $ readIORef parent
88− liftIO $ writeIORef parent $ DOM.toNode df
89− liftIO $ writeIORef hydrationMode HydrationMode_Immediate
90− pure $ do
91− liftIO $ writeIORef parent initialParent
92− liftIO $ writeIORef hydrationMode HydrationMode_Hydrating
93− addHydrationStep $ do
94− -- Delete up to the end marker
95− after <- deleteToPrerenderEnd
96− insertBefore df after
75+-- | Render the first widget on the server, and the second on the client. The
76+-- hydration builder will run *both* widgets, updating the result dynamic at
77+-- switchover time.
78+prerender
79+ :: (Functor m, Prerender t m)
80+ => m a -> ((PrerenderClientConstraint t (Client m)) => Client m a) -> m (Dynamic t a)
81+prerender server client = snd <$> prerenderImpl ((,) () <$> server) client
82+
83+-- | Render the first widget on the server, and the second on the client. The
84+-- hydration builder will run *both* widgets.
85+prerender_
86+ :: (Functor m, Reflex t, Prerender t m)
87+ => m () -> ((PrerenderClientConstraint t (Client m)) => Client m ()) -> m ()
88+prerender_ server client = void $ prerenderImpl ((,) () <$> server) client
89+
90+class Prerender t m | m -> t where
91+ -- | Monad in which the client widget is built
92+ type Client m :: * -> *
93+ -- | This function should be considered internal: it should only be used where
94+ -- the resultant 'Maybe' isn't used to change what is built in the DOM, or
95+ -- hydration will fail.
96+ prerenderImpl :: m (a, b) -> ((PrerenderClientConstraint t (Client m)) => Client m b) -> m (Maybe a, Dynamic t b)
97+
98+instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (ImmediateDomBuilderT t m) where
99+ type Client (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m
100+ prerenderImpl _ client = (,) Nothing . pure <$> client
101+
102+instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT t m) where
103+ -- | PostBuildT is needed here because we delay running the immediate builder
104+ -- until after switchover, at which point the postBuild of @m@ has already fired
105+ type Client (HydrationDomBuilderT t m) = PostBuildT t (ImmediateDomBuilderT t m)
106+ -- | Runs the server widget up until switchover, then replaces it with the
107+ -- client widget.
108+ prerenderImpl server client = do
109+ env <- HydrationDomBuilderT ask
110+ events <- askEvents
111+ doc <- askDocument
112+ df <- Document.createDocumentFragment doc
113+ unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
114+ let immediateEnv = ImmediateDomBuilderEnv
115+ { _immediateDomBuilderEnv_document = doc
116+ , _immediateDomBuilderEnv_parent = DOM.toNode df
117+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
118+ , _immediateDomBuilderEnv_commitAction = pure ()
119+ }
120+ (b', trigger) <- newTriggerEvent
121+ addHydrationStep $ do
122+ liftIO . trigger <=< lift $ runImmediateDomBuilderT (runPostBuildT client $ void b') immediateEnv events
123+ insertBefore df =<< deleteToPrerenderEnd
124+ ((a, b0), _) <- lift $ runHydrationDomBuilderT server env events
125+ (,) (Just a) <$> holdDyn b0 b'
126+
127+instance SupportsStaticDomBuilder t m => Prerender t (StaticDomBuilderT t m) where
128+ type Client (StaticDomBuilderT t m) = ImmediateDomBuilderT t m
129+ prerenderImpl server _ = do
130+ _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()
131+ (a, b) <- server
132+ _ <- element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
133+ pure (Just a, pure b)
134+
135+instance (Prerender t m, Monad m) => Prerender t (ReaderT r m) where
136+ type Client (ReaderT r m) = Client m
137+ prerenderImpl server client = do
138+ r <- ask
139+ lift $ prerenderImpl (runReaderT server r) client
140+
141+instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (StateT s m) where
142+ type Client (StateT s m) = Client m
143+ prerenderImpl server client = do
144+ s <- get
145+ (ma, evt) <- lift $ prerenderImpl
146+ (do ((a, b), s') <- runStateT server s; pure ((a, s'), b))
147+ client
148+ traverse_ (put . snd) ma
149+ pure (fst <$> ma, evt)
150+
151+instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (DynamicWriterT t w m) where
152+ type Client (DynamicWriterT t w m) = Client m
153+ prerenderImpl (DynamicWriterT server) client = DynamicWriterT $ prerenderImpl server client
154+
155+instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (EventWriterT t w m) where
156+ type Client (EventWriterT t w m) = Client m
157+ prerenderImpl (EventWriterT server) client = EventWriterT $ prerenderImpl server client
158+
159+instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (RequesterT t request response m) where
160+ type Client (RequesterT t request response m) = Client m
161+ prerenderImpl (RequesterT server) client = RequesterT $ prerenderImpl server client
162+
163+instance (Prerender t m, Monad m, Functor (Client m)) => Prerender t (QueryT t q m) where
164+ type Client (QueryT t q m) = Client m
165+ prerenderImpl (QueryT server) client = QueryT $ prerenderImpl server client
166+
167+instance (Prerender t m, Monad m) => Prerender t (InputDisabledT m) where
168+ type Client (InputDisabledT m) = Client m
169+ prerenderImpl (InputDisabledT server) client = InputDisabledT $ prerenderImpl server client
170+
171+instance (Prerender t m, Monad m) => Prerender t (PostBuildT t m) where
172+ type Client (PostBuildT t m) = Client m
173+ prerenderImpl (PostBuildT server) client = PostBuildT $ prerenderImpl server client
97174
98175startMarker, endMarker :: IsString s => s
99176startMarker = "prerender/start"
@@ -125,33 +202,3 @@ deleteToPrerenderEnd = do
125202 deleteBetweenExclusive startNode endNode
126203 setPreviousNode $ Just $ DOM.toNode endNode -- TODO probably not necessary
127204 pure endNode
128−
129−data NoJavascript -- This type should never have a HasJS instance
130−
131−instance (js ~ NoJavascript, SupportsStaticDomBuilder t m) => Prerender js (StaticDomBuilderT t m) where
132− prerenderClientDict = Nothing
133− prerenderWrapper = do
134− _ <- element "script" (def & initialAttributes .~ Map.singleton "type" startMarker) $ pure ()
135− pure $ void $ element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
136−
137−instance (Prerender js m, Monad m, ReflexHost t) => Prerender js (PostBuildT t m) where
138− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
139−
140−instance (Prerender js m, Monad m) => Prerender js (DynamicWriterT t w m) where
141− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
142−
143−instance (Prerender js m, Monad m) => Prerender js (EventWriterT t w m) where
144− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
145−
146−instance (Prerender js m, Monad m) => Prerender js (ReaderT w m) where
147− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
148−
149−instance (Prerender js m, Monad m) => Prerender js (RequesterT t request response m) where
150− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
151−
152−instance (Prerender js m, Monad m) => Prerender js (QueryT t q m) where
153− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
154−
155−instance (Prerender js m, Monad m) => Prerender js (InputDisabledT m) where
156− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
157−