@@ -5,6 +5,7 @@
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE RecursiveDo #-}
89{-# LANGUAGE ScopedTypeVariables #-}
910{-# LANGUAGE TemplateHaskell #-}
1011{-# LANGUAGE TypeFamilies #-}
@@ -21,18 +22,22 @@ import Prelude hiding ((.))
2122import Control.Category
2223import Control.Concurrent
2324import Control.Lens
24−import Control.Monad
25+import Control.Monad hiding (sequence, sequence_)
2526import Control.Monad.Fix
2627import Control.Monad.IO.Class
2728import Control.Monad.Primitive
29+import Control.Monad.Reader
2830import Control.Monad.Ref
2931import Control.Monad.Trans.Class
3032import Data.ByteString (ByteString)
3133import Data.Dependent.Sum (DSum (..))
34+import Data.Foldable (for_)
3235import Data.Functor.Sum
3336import Data.IORef
3437import Data.Monoid ((<>))
3538import Data.Text (Text)
39+import Data.Foldable (sequence_)
40+import Data.Traversable (sequence)
3641import GHCJS.DOM hiding (bracket, catch)
3742import GHCJS.DOM.Document
3843import GHCJS.DOM.Node
@@ -42,10 +47,11 @@ import Obelisk.Route.Frontend
4247import Reflex.Dom.Core
4348import Reflex.Host.Class
4449import qualified Reflex.TriggerEvent.Base as TriggerEvent
50+import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)
4551
4652makePrisms ''Sum
4753
48−type ObeliskWidget t x route m =
54+type ObeliskWidget js t route m =
4955 ( DomBuilder t m
5056 , MonadFix m
5157 , MonadHold t m
@@ -53,8 +59,6 @@ type ObeliskWidget t x route m =
5359 , MonadReflexCreateTrigger t m
5460 , PostBuild t m
5561 , PerformEvent t m
56− , MonadIO m
57− , MonadIO (Performable m)
5862 , TriggerEvent t m
5963 , HasDocument m
6064 , MonadRef m
@@ -63,73 +67,25 @@ type ObeliskWidget t x route m =
6367 , Ref (Performable m) ~ Ref IO
6468 , MonadFix (Performable m)
6569 , PrimMonad m
66− , Prerender x m
67− , SetRoute t route m
70+ , Prerender js t m
71+ , PrebuildAgnostic t route m
72+ , PrebuildAgnostic t route (Client m)
73+ -- TODO Remove these. Probably requires a new class to allow executable-configs to work without being inside a `prerender`
74+ , MonadIO m
75+ , MonadIO (Performable m)
76+ )
77+
78+type PrebuildAgnostic t route m =
79+ ( SetRoute t route m
6880 , RouteToUrl route m
81+ , MonadFix m
6982 )
7083
7184data Frontend route = Frontend
72− { _frontend_head :: !(forall t m x. ObeliskWidget t x route m => RoutedT t route m ())
73− , _frontend_body :: !(forall t m x. ObeliskWidget t x route m => RoutedT t route m ())
85+ { _frontend_head :: !(forall js t m. ObeliskWidget js t route m => RoutedT t route m ())
86+ , _frontend_body :: !(forall js t m. ObeliskWidget js t route m => RoutedT t route m ())
7487 }
7588
76−type Widget' x = ImmediateDomBuilderT DomTimeline (DomCoreWidget x)
77−
78−-- | A widget that isn't attached to any particular part of the DOM hierarchy
79−type FloatingWidget x = TriggerEventT DomTimeline (DomCoreWidget x)
80−
81−type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (PerformEventT DomTimeline DomHost))
82−
83−--TODO: Rename
84−{-# INLINABLE attachWidget''' #-}
85−attachWidget'''
86− :: (EventChannel -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))
87− -> IO ()
88−attachWidget''' w = runDomHost $ do
89− events <- liftIO newChan
90− (postBuildTriggerRef, fc@(FireCommand fire)) <- hostPerformEventT $ w events
91− mPostBuildTrigger <- readRef postBuildTriggerRef
92− forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
93− liftIO $ processAsyncEvents events fc
94−
95−--TODO: This is a collection of random stuff; we should make it make some more sense and then upstream to reflex-dom-core
96−runWithHeadAndBody
97− :: ( (forall c. Widget' () c -> FloatingWidget () c) -- "Append to head"
98− -> (forall c. Widget' () c -> FloatingWidget () c) -- "Append to body"
99− -> FloatingWidget () ()
100− )
101− -> JSM ()
102−runWithHeadAndBody app = withJSContextSingletonMono $ \jsSing -> do
103− globalDoc <- currentDocumentUnchecked
104− headFragment <- createDocumentFragment globalDoc
105− bodyFragment <- createDocumentFragment globalDoc
106− unreadyChildren <- liftIO $ newIORef 0
107− let commit = do
108− headElement <- getHeadUnchecked globalDoc
109− bodyElement <- getBodyUnchecked globalDoc
110− void $ inAnimationFrame' $ \_ -> do
111− replaceElementContents headElement headFragment
112− replaceElementContents bodyElement bodyFragment
113− liftIO $ attachWidget''' $ \events -> flip runWithJSContextSingleton jsSing $ do
114− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
115− let appendImmediateDom :: DOM.DocumentFragment -> Widget' () c -> FloatingWidget () c
116− appendImmediateDom df w = do
117− events' <- TriggerEvent.askEvents
118− lift $ do
119− doc <- getOwnerDocumentUnchecked df
120− let builderEnv = ImmediateDomBuilderEnv
121− { _immediateDomBuilderEnv_document = doc
122− , _immediateDomBuilderEnv_parent = toNode df
123− , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
124− , _immediateDomBuilderEnv_commitAction = commit
125− }
126− runImmediateDomBuilderT w builderEnv events'
127− flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (appendImmediateDom headFragment) (appendImmediateDom bodyFragment)
128− liftIO (readIORef unreadyChildren) >>= \case
129− 0 -> DOM.liftJSM commit
130− _ -> return ()
131− return postBuildTriggerRef
132−
13389runFrontend :: forall backendRoute route. Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName -> Frontend (R route) -> JSM ()
13490runFrontend validFullEncoder frontend = do
13591 let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))
@@ -145,12 +101,21 @@ runFrontend validFullEncoder frontend = do
145101 , MonadFix m
146102 , MonadFix (Performable m)
147103 )
148− => RoutedT t (R route) (SetRouteT t (R route) (RouteToUrlT (R route) m)) a
104+ => Event t ()
105+ -> RoutedT t (R route) (SetRouteT t (R route) (RouteToUrlT (R route) m)) a
149106 -> m a
150107 runMyRouteViewT = runRouteViewT ve
151− runWithHeadAndBody $ \appendHead appendBody -> runMyRouteViewT $ do
152− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ _frontend_head frontend
153− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ _frontend_body frontend
108+ runHydrationWidgetWithHeadAndBody (pure ()) $ \appendHead appendBody -> do
109+ rec switchover <- runMyRouteViewT switchover $ do
110+ (switchover, fire) <- newTriggerEvent
111+ mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ do
112+ _frontend_head frontend
113+ mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ do
114+ _frontend_body frontend
115+ switchover' <- lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
116+ performEvent_ $ liftIO (fire ()) <$ switchover'
117+ pure switchover
118+ pure ()
154119
155120renderFrontendHtml
156121 :: (t ~ DomTimeline)
@@ -163,6 +128,9 @@ renderFrontendHtml urlEnc route headWidget bodyWidget = do
163128 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline
164129 html <- fmap snd $ renderStatic $ fmap fst $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $
165130 el "html" $ do
166− el "head" headWidget
131+ el "head" $ do
132+ let baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes
133+ -- The order here is important - baseTag has to be before headWidget!
134+ baseTag >> injectExecutableConfigs >> headWidget
167135 el "body" bodyWidget
168136 return $ "<!DOCTYPE html>" <> html