git.iko.soy/reflex-dom
on develop help sign in
Add main functions for hydration
commit73b20ef63a3d4bce1109ea7852bec2e89932bdaf authorTom Smalley <tfsmalley@gmail.com> dateThu 3 Jan 2019, 13:06 (8 years ago) parent97432ad
5 files changed+77−14
compare with develop
unifiedsplit
reflex-dom-core/src/Reflex/Dom/Main.hs+55−1 reflex-dom/benchmarks/krausest.hs+8−8 reflex-dom/reflex-dom.cabal+1−1 reflex-dom/src/Reflex/Dom.hs+1−1 reflex-dom/src/Reflex/Dom/Internal.hs+12−3
reflex-dom-core/src/Reflex/Dom/Main.hs+55−1
@@ -149,6 +149,61 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM
149149 flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)
150150 return postBuildTriggerRef
151151
152+{-# INLINABLE mainHydrationWidgetWithHeadImmediate #-}
153+-- | Warning: `mainHydrationWidgetWithHeadImmediate` is provided only as performance tweak. It is expected to disappear in future releases.
154+mainHydrationWidgetWithHeadImmediate :: HydrationWidget () () -> HydrationWidget () () -> JSM ()
155+mainHydrationWidgetWithHeadImmediate head' body = do
156+ runHydrationWidgetWithHeadAndBodyImmediate (pure ()) $ \appendHead appendBody -> do
157+ appendHead head'
158+ appendBody body
159+
160+{-# INLINABLE attachHydrationWidgetImmediate #-}
161+attachHydrationWidgetImmediate
162+ :: JSContextSingleton ()
163+ -> (EventChannel -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))
164+ -> IO ()
165+attachHydrationWidgetImmediate jsSing w = do
166+ events <- newChan
167+ runDomHost $ flip runTriggerEventT events $ mdo
168+ (postBuildTriggerRef, fc@(FireCommand fire)) <- lift $ hostPerformEventT $ w events
169+ mPostBuildTrigger <- readRef postBuildTriggerRef
170+ lift $ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
171+ liftIO $ processAsyncEvents events fc
172+
173+{-# INLINABLE runHydrationWidgetWithHeadAndBodyImmediate #-}
174+runHydrationWidgetWithHeadAndBodyImmediate
175+ :: IO ()
176+ -> ( (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to head"
177+ -> (forall c. HydrationWidget () c -> FloatingWidget () c) -- "Append to body"
178+ -> FloatingWidget () ()
179+ )
180+ -> JSM ()
181+runHydrationWidgetWithHeadAndBodyImmediate switchoverAction app = withJSContextSingletonMono $ \jsSing -> do
182+ globalDoc <- currentDocumentUnchecked
183+ headElement <- getHeadUnchecked globalDoc
184+ bodyElement <- getBodyUnchecked globalDoc
185+ unreadyChildren <- liftIO $ newIORef 0
186+ hydrationMode <- liftIO $ newIORef HydrationMode_Immediate
187+ liftIO $ attachHydrationWidgetImmediate jsSing $ \events -> flip runWithJSContextSingleton jsSing $ do
188+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
189+ let hydrateDom :: DOM.Node -> HydrationWidget () c -> FloatingWidget () c
190+ hydrateDom n w = do
191+ events' <- TriggerEvent.askEvents
192+ parent <- liftIO $ newIORef $ toNode n
193+ lift $ do
194+ let builderEnv = HydrationDomBuilderEnv
195+ { _hydrationDomBuilderEnv_document = globalDoc
196+ , _hydrationDomBuilderEnv_parent = parent
197+ , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
198+ , _hydrationDomBuilderEnv_commitAction = pure ()
199+ , _hydrationDomBuilderEnv_hydrationMode = hydrationMode
200+ , _hydrationDomBuilderEnv_switchover = never
201+ }
202+ (a, _res) <- runHydrationDomBuilderT w builderEnv events'
203+ pure a
204+ flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)
205+ return postBuildTriggerRef
206+
152207{-# INLINE mainWidget #-}
153208mainWidget :: (forall x. Widget x ()) -> JSM ()
154209mainWidget = mainWidget'
@@ -283,7 +338,6 @@ processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do
283338 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
284339 return ()
285340
286−
287341-- | Run a reflex-dom application inside of an existing DOM element with the given ID
288342mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()
289343mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do
reflex-dom/benchmarks/krausest.hs+8−8
@@ -26,17 +26,17 @@ type TableDiff = PatchIntMap Row
2626main :: IO ()
2727main = do
2828 seed <- randomIO
29− mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed)
29+ mainWidgetWithHead {-mainHydrationWidgetWithHeadImmediate-} headW (bodyW seed)
3030
31−titleW :: MonadWidget t m => m ()
31+titleW :: DomBuilder t m => m ()
3232titleW = text "Reflex-dom keyed"
3333
34−headW :: MonadWidget t m => m ()
34+headW :: DomBuilder t m => m ()
3535headW = do
3636 el "title" titleW
3737 elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank
3838
39−bodyW :: forall t m. MonadWidget t m => Entropy -> m ()
39+bodyW :: forall t m. (MonadFix m, MonadHold t m, DomBuilder t m) => Entropy -> m ()
4040bodyW seed = divClass "main" $ divClass "container" $ mdo
4141 buttonEvents <- divClass "jumbotron" $ divClass "row" $ do
4242 divClass "col-md-6" $ el "h1" titleW
@@ -75,14 +75,14 @@ step (m, t) f = ((m', t'), dt)
7575 (m', dt) = f (m, t)
7676 t' = applyAlways dt t
7777
78−buttonW :: MonadWidget t m => Text -> Text -> a -> m (Event t a)
78+buttonW :: DomBuilder t m => Text -> Text -> a -> m (Event t a)
7979buttonW id txt val = divClass "col-sm-6 smallpad" $ buttonW' ("class" =: "btn btn-primary btn-block" <> "id" =: id)
8080 where
8181 buttonW' attrs = do
8282 (b, _) <- elAttr' "button" attrs $ text txt
8383 pure $ val <$ domEvent Click b
8484
85−tableW :: MonadWidget t m => Event t TableDiff -> m (Event t (IntMap Step))
85+tableW :: (MonadHold t m, DomBuilder t m) => Event t TableDiff -> m (Event t (IntMap Step))
8686tableW diff = do
8787 elClass "table" "table table-hover table-striped test-data" $ do
8888 el "tbody" $ do
@@ -90,7 +90,7 @@ tableW diff = do
9090 rowEvents <- holdIncremental v0 v'
9191 return $ mergeIntIncremental rowEvents
9292
93−rowW :: MonadWidget t m => Row -> m (Event t Step)
93+rowW :: DomBuilder t m => Row -> m (Event t Step)
9494rowW row = elClass "tr" (if selected row then "danger" else "") $
9595 do
9696 elClass "td" "col-md-1" $ do
@@ -102,7 +102,7 @@ rowW row = elClass "tr" (if selected row then "danger" else "") $
102102 where
103103 tagClick f el = f row <$ (domEvent Click el)
104104
105−deleteW :: MonadWidget t m => m ()
105+deleteW :: DomBuilder t m => m ()
106106deleteW = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") blank
107107
108108
reflex-dom/reflex-dom.cabal+1−1
@@ -155,7 +155,7 @@ executable krausest
155155 ghc-options: -dedupe
156156 cpp-options: -DGHCJS_BROWSER -DGHCJS_GC_INTERVAL=60000
157157 else
158− buildable: False
158+ --buildable: False
159159 type: exitcode-stdio-1.0
160160
161161source-repository head
reflex-dom/src/Reflex/Dom.hs+1−1
@@ -2,5 +2,5 @@ module Reflex.Dom (module X) where
22
33import Foreign.JavaScript.Orphans ()
44import Reflex.Dom.Core as X hiding (mainWidget, mainWidgetInElementById, mainWidgetWithCss,
5− mainWidgetWithHead, mainWidgetWithHead', runApp')
5+ mainWidgetWithHead, mainWidgetWithHead', runApp', mainHydrationWidgetWithHeadImmediate)
66import Reflex.Dom.Internal as X
reflex-dom/src/Reflex/Dom/Internal.hs+12−3
@@ -5,17 +5,17 @@
55{-# LANGUAGE TypeFamilies #-}
66module Reflex.Dom.Internal
77 (module Main, run, mainWidget, mainWidgetWithHead, mainWidgetWithCss,
8− mainWidgetWithHead', mainWidgetInElementById, runApp') where
8+ mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHead, mainHydrationWidgetWithHeadImmediate) where
99
1010import Data.ByteString (ByteString)
1111import Data.Text (Text)
1212import Reflex.Dom.Core (Widget)
1313import Reflex.Dom.Main as Main hiding
1414 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,
15− mainWidgetWithHead', mainWidgetInElementById, runApp')
15+ mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)
1616import qualified Reflex.Dom.Main as Main
1717 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,
18− mainWidgetWithHead', mainWidgetInElementById, runApp')
18+ mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)
1919
2020#if defined(ghcjs_HOST_OS)
2121run :: a -> a
@@ -101,3 +101,12 @@ mainWidgetInElementById eid w = run $ Main.mainWidgetInElementById eid w
101101runApp' :: (forall x. AppInput DomTimeline -> Widget x (AppOutput DomTimeline)) -> IO ()
102102runApp' app = run $ Main.runApp' app
103103{-# INLINE runApp' #-}
104+
105+mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> IO ()
106+mainHydrationWidgetWithHead h b = run $ Main.mainHydrationWidget h b
107+{-# INLINE mainHydrationWidgetWithHead #-}
108+
109+mainHydrationWidgetWithHeadImmediate :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> IO ()
110+mainHydrationWidgetWithHeadImmediate h b = run $ Main.mainHydrationWidgetWithHeadImmediate h b
111+{-# INLINE mainHydrationWidgetWithHeadImmediate #-}
112+