{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Reflex.Dom.Prerender
( Prerender (..)
, prerender_
, PrerenderClientConstraint
, PrerenderBaseConstraints
) where
import Control.Monad.Primitive (PrimMonad(..))
import Control.Monad.Reader
import Control.Monad.Ref (MonadRef(..), MonadAtomicRef(..))
import Data.IORef (IORef, newIORef)
import Data.Semigroup (Semigroup)
import Data.Text (Text)
import Data.Void
import Foreign.JavaScript.TH
import GHCJS.DOM.Types (MonadJSM)
import Reflex hiding (askEvents)
import Reflex.Dom.Builder.Class
import Reflex.Dom.Builder.Hydratable
import Reflex.Dom.Builder.Immediate
import Reflex.Dom.Builder.InputDisabled
import Reflex.Dom.Builder.Static
import Reflex.Host.Class
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import qualified GHCJS.DOM.Document as Document
import qualified GHCJS.DOM.Node as Node
import qualified GHCJS.DOM.Types as DOM
type PrerenderClientConstraint t m =
( DomBuilder t m
, DomBuilderSpace m ~ GhcjsDomSpace
, DomRenderHook t m
, HasDocument m
, TriggerEvent t m
, PrerenderBaseConstraints t m
)
type PrerenderBaseConstraints t m =
( MonadFix m
, MonadHold t m
, MonadJSM (Performable m)
, MonadJSM m
, MonadRef (Performable m)
, MonadRef m
, MonadReflexCreateTrigger t m
, MonadSample t (Performable m)
, PerformEvent t m
, PostBuild t m
, PrimMonad m
, Ref (Performable m) ~ IORef
, Ref m ~ IORef
)
prerender_
:: (Functor m, Reflex t, Prerender t m)
=> m () -> Client m () -> m ()
prerender_ server client = void $ prerender server client
class (PrerenderClientConstraint t (Client m), Client (Client m) ~ Client m, Prerender t (Client m)) => Prerender t m | m -> t where
type Client m :: * -> *
prerender :: m a -> Client m a -> m (Dynamic t a)
instance (ReflexHost t, Adjustable t m, PrerenderBaseConstraints t m) => Prerender t (HydrationDomBuilderT GhcjsDomSpace t m) where
type Client (HydrationDomBuilderT GhcjsDomSpace t m) = HydrationDomBuilderT GhcjsDomSpace t m
prerender _ client = pure <$> client
instance (Adjustable t m, PrerenderBaseConstraints t m, ReflexHost t) => Prerender t (HydrationDomBuilderT HydrationDomSpace t m) where
type Client (HydrationDomBuilderT HydrationDomSpace t m) = PostBuildT t (HydrationDomBuilderT GhcjsDomSpace t m)
prerender server client = do
env <- HydrationDomBuilderT ask
events <- askEvents
doc <- askDocument
serverDf <- Document.createDocumentFragment doc
df <- Document.createDocumentFragment doc
unreadyChildren <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_unreadyChildren
immediateMode <- liftIO $ newIORef HydrationMode_Immediate
delayed <- liftIO $ newIORef $ pure ()
let clientEnv = env
{ _hydrationDomBuilderEnv_parent = Left $ DOM.toNode df
, _hydrationDomBuilderEnv_hydrationMode = immediateMode
}
serverEnv = HydrationDomBuilderEnv
{ _hydrationDomBuilderEnv_document = doc
, _hydrationDomBuilderEnv_parent = Left $ DOM.toNode serverDf
, _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
, _hydrationDomBuilderEnv_commitAction = pure ()
, _hydrationDomBuilderEnv_delayed = delayed
, _hydrationDomBuilderEnv_hydrationMode = immediateMode
, _hydrationDomBuilderEnv_switchover = never
}
a0 <- lift $ runHydrationDomBuilderT server serverEnv events
(a', trigger) <- newTriggerEvent
getHydrationMode >>= \case
HydrationMode_Immediate -> do
liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void a') clientEnv events
append $ DOM.toNode df
HydrationMode_Hydrating -> addHydrationStep $ do
liftIO . trigger <=< lift $ runHydrationDomBuilderT (runPostBuildT client $ void a') clientEnv events
insertBefore df =<< deleteToPrerenderEnd doc
holdDyn a0 a'
newtype UnrunnableT t m a = UnrunnableT (ReaderT Void m a)
deriving (Functor, Applicative, Monad, MonadTrans)
unrunnable :: UnrunnableT t m a
unrunnable = UnrunnableT $ ReaderT $ \case {}
instance (Reflex t, Monad m) => DomBuilder t (UnrunnableT t m) where
type DomBuilderSpace (UnrunnableT t m) = GhcjsDomSpace
textNode _ = unrunnable
commentNode _ = unrunnable
element _ _ _ = unrunnable
inputElement _ = unrunnable
textAreaElement _ = unrunnable
selectElement _ _ = unrunnable
placeRawElement _ = unrunnable
wrapRawElement _ _ = unrunnable
instance (Reflex t, Monad m) => NotReady t (UnrunnableT t m) where
notReadyUntil _ = unrunnable
notReady = unrunnable
instance (Reflex t, Monad m) => Adjustable t (UnrunnableT t m) where
runWithReplace _ _ = unrunnable
traverseIntMapWithKeyWithAdjust _ _ _ = unrunnable
traverseDMapWithKeyWithAdjust _ _ _ = unrunnable
traverseDMapWithKeyWithAdjustWithMove _ _ _ = unrunnable
instance (Reflex t, Monad m) => PerformEvent t (UnrunnableT t m) where
type Performable (UnrunnableT t m) = UnrunnableT t m
performEvent _ = unrunnable
performEvent_ _ = unrunnable
instance Monad m => MonadRef (UnrunnableT t m) where
type Ref (UnrunnableT t m) = Ref IO
newRef _ = unrunnable
readRef _ = unrunnable
writeRef _ _ = unrunnable
instance Monad m => MonadAtomicRef (UnrunnableT t m) where
atomicModifyRef _ _ = unrunnable
instance Monad m => HasDocument (UnrunnableT t m) where
askDocument = unrunnable
instance Monad m => TriggerEvent t (UnrunnableT t m) where
newTriggerEvent = unrunnable
newTriggerEventWithOnComplete = unrunnable
newEventWithLazyTriggerWithOnComplete _ = unrunnable
instance Monad m => MonadReflexCreateTrigger t (UnrunnableT t m) where
newEventWithTrigger _ = unrunnable
newFanEventWithTrigger _ = unrunnable
instance Monad m => MonadFix (UnrunnableT t m) where
mfix _ = unrunnable
instance (Monad m, MonadHold t m) => MonadHold t (UnrunnableT t m) where
hold _ _ = unrunnable
holdDyn _ _ = unrunnable
holdIncremental _ _ = unrunnable
buildDynamic _ _ = unrunnable
headE _ = unrunnable
now = unrunnable
instance Monad m => MonadSample t (UnrunnableT t m) where
sample _ = unrunnable
instance Monad m => MonadIO (UnrunnableT t m) where
liftIO _ = unrunnable
#ifndef ghcjs_HOST_OS
instance Monad m => MonadJSM (UnrunnableT t m) where
liftJSM' _ = unrunnable
#endif
instance (Reflex t, Monad m) => PostBuild t (UnrunnableT t m) where
getPostBuild = unrunnable
instance Monad m => PrimMonad (UnrunnableT t m) where
type PrimState (UnrunnableT t m) = PrimState IO
primitive _ = unrunnable
instance (Reflex t, Monad m) => DomRenderHook t (UnrunnableT t m) where
withRenderHook _ _ = unrunnable
requestDomAction _ = unrunnable
requestDomAction_ _ = unrunnable
instance (Reflex t, Monad m, MonadHold t m) => Prerender t (UnrunnableT t m) where
type Client (UnrunnableT t m) = UnrunnableT t m
prerender _ _ = unrunnable
instance (SupportsStaticDomBuilder t m) => Prerender t (StaticDomBuilderT t m) where
type Client (StaticDomBuilderT t m) = UnrunnableT t m
prerender server _ = do
_ <- commentNode $ CommentNodeConfig startMarker Nothing
a <- server
_ <- commentNode $ CommentNodeConfig endMarker Nothing
pure $ pure a
instance (Prerender t m, Monad m) => Prerender t (ReaderT r m) where
type Client (ReaderT r m) = ReaderT r (Client m)
prerender server client = do
r <- ask
lift $ prerender (runReaderT server r) (runReaderT client r)
instance (Prerender t m, Monad m, Reflex t, MonadFix m, Monoid w) => Prerender t (DynamicWriterT t w m) where
type Client (DynamicWriterT t w m) = DynamicWriterT t w (Client m)
prerender server client = do
x <- lift $ prerender (runDynamicWriterT server) (runDynamicWriterT client)
let (a, w') = splitDynPure x
w = join w'
tellDyn w
pure a
instance (Prerender t m, Monad m, Reflex t, Semigroup w) => Prerender t (EventWriterT t w m) where
type Client (EventWriterT t w m) = EventWriterT t w (Client m)
prerender server client = do
x <- lift $ prerender (runEventWriterT server) (runEventWriterT client)
let (a, w') = splitDynPure x
w = switch $ current w'
tellEvent w
pure a
instance (Prerender t m, MonadFix m, Reflex t) => Prerender t (RequesterT t request response m) where
type Client (RequesterT t request response m) = RequesterT t request response (Client m)
prerender server client = mdo
let fannedResponses = fanInt responses
withFannedResponses :: forall m' a. Monad m' => RequesterT t request response m' a -> Int -> m' (a, Event t (IntMap (RequesterData request)))
withFannedResponses w selector = do
(x, e) <- runRequesterT w (selectInt fannedResponses selector)
pure (x, fmapCheap (IntMap.singleton selector) e)
(result, requestsDyn) <- fmap splitDynPure $ lift $ prerender (withFannedResponses server 0) (withFannedResponses client 1)
responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requestsDyn
return result
instance (Prerender t m, Monad m, Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q) => Prerender t (QueryT t q m) where
type Client (QueryT t q m) = QueryT t q (Client m)
prerender server client = mdo
result <- queryDyn query
x <- lift $ prerender (runQueryT server result) (runQueryT client result)
let (a, inc) = splitDynPure x
query = incrementalToDynamic =<< inc
pure a
instance (Prerender t m, Monad m) => Prerender t (InputDisabledT m) where
type Client (InputDisabledT m) = InputDisabledT (Client m)
prerender (InputDisabledT server) (InputDisabledT client) = InputDisabledT $ prerender server client
instance (Prerender t m, Monad m) => Prerender t (HydratableT m) where
type Client (HydratableT m) = HydratableT (Client m)
prerender (HydratableT server) (HydratableT client) = HydratableT $ prerender server client
instance (Prerender t m, Monad m, ReflexHost t) => Prerender t (PostBuildT t m) where
type Client (PostBuildT t m) = PostBuildT t (Client m)
prerender server client = PostBuildT $ do
pb <- ask
lift $ prerender (runPostBuildT server pb) (runPostBuildT client pb)
startMarker, endMarker :: Text
startMarker = "prerender/start"
endMarker = "prerender/end"
deleteToPrerenderEnd :: (MonadIO m, MonadJSM m, Reflex t, MonadFix m) => DOM.Document -> HydrationRunnerT t m DOM.Comment
deleteToPrerenderEnd doc = do
startNode <- hydrateComment doc startMarker Nothing
let go (n :: Int) lastNode = Node.getNextSibling lastNode >>= \case
Nothing -> do
c <- Document.createComment doc endMarker
insertAfterPreviousNode c
pure c
Just node -> DOM.castTo DOM.Comment node >>= \case
Nothing -> go n node
Just c -> Node.getTextContentUnchecked c >>= \case
t | t == startMarker -> go (succ n) node
| t == endMarker -> case n of
0 -> pure c
_ -> go (pred n) node
| otherwise -> go n node
endNode <- go 0 $ DOM.toNode startNode
deleteBetweenExclusive startNode endNode
setPreviousNode $ Just $ DOM.toNode endNode
pure endNode