@@ -9,20 +9,27 @@
9{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE Rank2Types #-}
11{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeSynonymInstances #-}
14{-# LANGUAGE TypeSynonymInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
17+-- | Render the first widget on the server, and the second on the client.
15module Reflex.Dom.Prerender
18module Reflex.Dom.Prerender
16 ( Prerender (..)
19 ( Prerender (..)
17 , prerender
20 , prerender
18 , PrerenderClientConstraint
22 , PrerenderClientConstraint
21import Control.Lens ((&), (.~))
25import Control.Lens ((&), (.~))
26+import Control.Monad.Primitive (PrimMonad)
22import Control.Monad.Reader
27import Control.Monad.Reader
23−import Data.Constraint
28+import Control.Monad.Ref (MonadRef(..))
29+import Control.Monad.State.Strict
24import Data.Default
30import Data.Default
31+import Data.Foldable (traverse_)
25−import Data.IORef (modifyIORef', readIORef, newIORef, writeIORef)
32+import Data.IORef (IORef, modifyIORef', readIORef, newIORef)
26import Data.String (IsString)
33import Data.String (IsString)
27import qualified GHCJS.DOM.Element as Element
34import qualified GHCJS.DOM.Element as Element
28import qualified GHCJS.DOM.Types as DOM
35import qualified GHCJS.DOM.Types as DOM
@@ -33,67 +40,137 @@ import GHCJS.DOM.Types (MonadJSM)
33import Reflex hiding (askEvents)
40import Reflex hiding (askEvents)
34import Reflex.Dom.Builder.Class
41import Reflex.Dom.Builder.Class
35import Reflex.Dom.Builder.InputDisabled
42import 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)
37import Reflex.Dom.Builder.Hydration
44import Reflex.Dom.Builder.Hydration
38import Reflex.Dom.Builder.Static
45import Reflex.Dom.Builder.Static
39import Reflex.Host.Class
46import Reflex.Host.Class
41−type PrerenderClientConstraint' js m =
48+type PrerenderClientConstraint t m =
42− ( HasJS js m
49+ ( DomBuilder t m
43− , HasJS js (Performable m)
50+ , DomBuilderSpace m ~ GhcjsDomSpace
44− , MonadJSM m
51+ , HasDocument m
45− , MonadJSM (Performable m)
52+ , TriggerEvent t m
46− , HasJSContext m
53+ , Prerender t m
47− , HasJSContext (Performable m)
54+ , PrerenderBaseConstraints t m
49− , MonadFix (Performable m)
52−type PrerenderClientConstraint js m =
57+type PrerenderBaseConstraints t m =
53− ( PrerenderClientConstraint' js m
58+ ( HasJSContext (Performable m)
54− , DomBuilderSpace m ~ GhcjsDomSpace
59+ , HasJSContext m
62+ , MonadJSM (Performable m)
64+ , MonadRef (Performable m)
66+ , MonadReflexCreateTrigger t m
67+ , MonadSample t (Performable m)
71+ , Ref (Performable m) ~ IORef
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
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
83+-- | Render the first widget on the server, and the second on the client. The
84+-- hydration builder will run *both* widgets.
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
57−class Prerender js m | m -> js where
90+class Prerender t m | m -> t where
58− prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m))
91+ -- | Monad in which the client widget is built
59− prerenderWrapper :: m (m ())
92+ type Client m :: * -> *
60− default prerenderWrapper :: (MonadTrans t, Monad n, m ~ t n, Prerender js n) => m (m ())
93+ -- | This function should be considered internal: it should only be used where
61− prerenderWrapper = lift $ lift <$> prerenderWrapper
94+ -- the resultant 'Maybe' isn't used to change what is built in the DOM, or
62−
95+ -- hydration will fail.
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
96+ prerenderImpl :: m (a, b) -> ((PrerenderClientConstraint t (Client m)) => Client m b) -> m (Maybe a, Dynamic t b)
67−prerender server client = do
97+
68− finalize <- prerenderWrapper
98+instance (Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (ImmediateDomBuilderT t m) where
69− a <- case prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)) of
99+ type Client (ImmediateDomBuilderT t m) = ImmediateDomBuilderT t m
70− Nothing -> server
100+ prerenderImpl _ client = (,) Nothing . pure <$> client
71− Just Dict -> client
101+
75−instance (PrerenderClientConstraint' js m, ReflexHost t) => Prerender js (ImmediateDomBuilderT t m) where
102+instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT t m) where
76− prerenderClientDict = Just Dict
103+ -- | PostBuildT is needed here because we delay running the immediate builder
77− prerenderWrapper = pure (pure ())
104+ -- until after switchover, at which point the postBuild of @m@ has already fired
78−
105+ type Client (HydrationDomBuilderT t m) = PostBuildT t (ImmediateDomBuilderT t m)
79−instance (PrerenderClientConstraint' js m, SupportsImmediateDomBuilder t m, ReflexHost t, PerformEvent t m) => Prerender js (HydrationDomBuilderT t m) where
106+ -- | Runs the server widget up until switchover, then replaces it with the
80− prerenderClientDict = Just Dict
107+ -- client widget.
81− prerenderWrapper = getHydrationMode >>= \case
108+ prerenderImpl server client = do
82− HydrationMode_Immediate -> pure (pure ())
83− HydrationMode_Hydrating -> do
84− parent <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent
109+ env <- HydrationDomBuilderT ask
85− hydrationMode <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationMode
110+ events <- askEvents
86− df <- Document.createDocumentFragment =<< askDocument
112+ df <- Document.createDocumentFragment doc
87− initialParent <- liftIO $ readIORef parent
113+ unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
88− liftIO $ writeIORef parent $ DOM.toNode df
114+ let immediateEnv = ImmediateDomBuilderEnv
89− liftIO $ writeIORef hydrationMode HydrationMode_Immediate
115+ { _immediateDomBuilderEnv_document = doc
90− pure $ do
116+ , _immediateDomBuilderEnv_parent = DOM.toNode df
91− liftIO $ writeIORef parent initialParent
117+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
92− liftIO $ writeIORef hydrationMode HydrationMode_Hydrating
118+ , _immediateDomBuilderEnv_commitAction = pure ()
120+ (b', trigger) <- newTriggerEvent
93− addHydrationStep $ do
121+ addHydrationStep $ do
94− -- Delete up to the end marker
122+ liftIO . trigger <=< lift $ runImmediateDomBuilderT (runPostBuildT client $ void b') immediateEnv events
95− after <- deleteToPrerenderEnd
123+ insertBefore df =<< deleteToPrerenderEnd
96− insertBefore df after
124+ ((a, b0), _) <- lift $ runHydrationDomBuilderT server env events
125+ (,) (Just a) <$> holdDyn b0 b'
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 ()
132+ _ <- element "script" (def & initialAttributes .~ Map.singleton "type" endMarker) $ pure ()
133+ pure (Just a, pure b)
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
139+ lift $ prerenderImpl (runReaderT server r) client
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
145+ (ma, evt) <- lift $ prerenderImpl
146+ (do ((a, b), s') <- runStateT server s; pure ((a, s'), b))
148+ traverse_ (put . snd) ma
149+ pure (fst <$> ma, evt)
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
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
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
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
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
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
98startMarker, endMarker :: IsString s => s
175startMarker, endMarker :: IsString s => s
99startMarker = "prerender/start"
176startMarker = "prerender/start"
@@ -125,33 +202,3 @@ deleteToPrerenderEnd = do
125 deleteBetweenExclusive startNode endNode
202 deleteBetweenExclusive startNode endNode
126 setPreviousNode $ Just $ DOM.toNode endNode -- TODO probably not necessary
203 setPreviousNode $ Just $ DOM.toNode endNode -- TODO probably not necessary
127 pure endNode
204 pure endNode
129−data NoJavascript -- This type should never have a HasJS instance
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 ()
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)))
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)))
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)))
146−instance (Prerender js m, Monad m) => Prerender js (ReaderT w m) where
147− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
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)))
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)))
155−instance (Prerender js m, Monad m) => Prerender js (InputDisabledT m) where
156− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))