73b20ef · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add main functions for hydration

73b20efTom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Main.hs+55−1

@@ -149,6 +149,61 @@ runHydrationWidgetWithHeadAndBody switchoverAction app = withJSContextSingletonM

149 flip runPostBuildT postBuild $ flip runTriggerEventT events $ app (hydrateDom $ toNode headElement) (hydrateDom $ toNode bodyElement)

150 return postBuildTriggerRef

151

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+

152{-# INLINE mainWidget #-}

207{-# INLINE mainWidget #-}

153mainWidget :: (forall x. Widget x ()) -> JSM ()

208mainWidget :: (forall x. Widget x ()) -> JSM ()

154mainWidget = mainWidget'

209mainWidget = mainWidget'

@@ -283,7 +338,6 @@ processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do

283 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

338 liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

284 return ()

339 return ()

285

340

286−

287-- | Run a reflex-dom application inside of an existing DOM element with the given ID

341-- | Run a reflex-dom application inside of an existing DOM element with the given ID

288mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()

342mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()

289mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do

343mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do

reflex-dom/benchmarks/krausest.hs+8−8

@@ -26,17 +26,17 @@ type TableDiff = PatchIntMap Row

26main :: IO ()

27main = do

28 seed <- randomIO

29− mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed)

29+ mainWidgetWithHead {-mainHydrationWidgetWithHeadImmediate-} headW (bodyW seed)

31−titleW :: MonadWidget t m => m ()

31+titleW :: DomBuilder t m => m ()

32titleW = text "Reflex-dom keyed"

34−headW :: MonadWidget t m => m ()

34+headW :: DomBuilder t m => m ()

35headW = do

36 el "title" titleW

37 elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank

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 ()

40bodyW seed = divClass "main" $ divClass "container" $ mdo

41 buttonEvents <- divClass "jumbotron" $ divClass "row" $ do

42 divClass "col-md-6" $ el "h1" titleW

@@ -75,14 +75,14 @@ step (m, t) f = ((m', t'), dt)

75 (m', dt) = f (m, t)

76 t' = applyAlways dt t

78−buttonW :: MonadWidget t m => Text -> Text -> a -> m (Event t a)

78+buttonW :: DomBuilder t m => Text -> Text -> a -> m (Event t a)

79buttonW id txt val = divClass "col-sm-6 smallpad" $ buttonW' ("class" =: "btn btn-primary btn-block" <> "id" =: id)

80 where

81 buttonW' attrs = do

82 (b, _) <- elAttr' "button" attrs $ text txt

83 pure $ val <$ domEvent Click b

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))

86tableW diff = do

87 elClass "table" "table table-hover table-striped test-data" $ do

88 el "tbody" $ do

@@ -90,7 +90,7 @@ tableW diff = do

90 rowEvents <- holdIncremental v0 v'

91 return $ mergeIntIncremental rowEvents

93−rowW :: MonadWidget t m => Row -> m (Event t Step)

93+rowW :: DomBuilder t m => Row -> m (Event t Step)

94rowW row = elClass "tr" (if selected row then "danger" else "") $

95 do

96 elClass "td" "col-md-1" $ do

@@ -102,7 +102,7 @@ rowW row = elClass "tr" (if selected row then "danger" else "") $

102 where

103 tagClick f el = f row <$ (domEvent Click el)

104

105−deleteW :: MonadWidget t m => m ()

105+deleteW :: DomBuilder t m => m ()

106deleteW = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") blank

107

108

reflex-dom/reflex-dom.cabal+1−1

@@ -155,7 +155,7 @@ executable krausest

155 ghc-options: -dedupe

156 cpp-options: -DGHCJS_BROWSER -DGHCJS_GC_INTERVAL=60000

157 else

158− buildable: False

158+ --buildable: False

159 type: exitcode-stdio-1.0

160

161source-repository head

reflex-dom/src/Reflex/Dom.hs+1−1

@@ -2,5 +2,5 @@ module Reflex.Dom (module X) where

3import Foreign.JavaScript.Orphans ()

4import Reflex.Dom.Core as X hiding (mainWidget, mainWidgetInElementById, mainWidgetWithCss,

5− mainWidgetWithHead, mainWidgetWithHead', runApp')

5+ mainWidgetWithHead, mainWidgetWithHead', runApp', mainHydrationWidgetWithHeadImmediate)

6import Reflex.Dom.Internal as X

reflex-dom/src/Reflex/Dom/Internal.hs+12−3

@@ -5,17 +5,17 @@

5{-# LANGUAGE TypeFamilies #-}

6module Reflex.Dom.Internal

7 (module Main, run, mainWidget, mainWidgetWithHead, mainWidgetWithCss,

8− mainWidgetWithHead', mainWidgetInElementById, runApp') where

8+ mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHead, mainHydrationWidgetWithHeadImmediate) where

10import Data.ByteString (ByteString)

11import Data.Text (Text)

12import Reflex.Dom.Core (Widget)

13import Reflex.Dom.Main as Main hiding

14 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

15− mainWidgetWithHead', mainWidgetInElementById, runApp')

15+ mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)

16import qualified Reflex.Dom.Main as Main

17 (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

18− mainWidgetWithHead', mainWidgetInElementById, runApp')

18+ mainWidgetWithHead', mainWidgetInElementById, runApp', mainHydrationWidgetWithHeadImmediate)

20#if defined(ghcjs_HOST_OS)

21run :: a -> a

@@ -101,3 +101,12 @@ mainWidgetInElementById eid w = run $ Main.mainWidgetInElementById eid w

101runApp' :: (forall x. AppInput DomTimeline -> Widget x (AppOutput DomTimeline)) -> IO ()

102runApp' app = run $ Main.runApp' app

103{-# 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+