575e1d3 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Move data-ssr from static builder to HydratableT

575e1d3Tom Smalley7 years ago

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

compare with develop

unifiedsplit

@@ -95,6 +95,7 @@ library

95 Reflex.Dom.Builder.Class.Events

96 Reflex.Dom.Builder.Immediate

97 Reflex.Dom.Builder.InputDisabled

98+ Reflex.Dom.Builder.Hydratable

98 Reflex.Dom.Builder.Static

99 Reflex.Dom.Builder.Static

99 Reflex.Dom.Class

100 Reflex.Dom.Class

100 Reflex.Dom.Core

101 Reflex.Dom.Core

reflex-dom-core/src/Reflex/Dom/Builder/Hydratable.hsnew file+116

@@ -0,0 +1,116 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE StandaloneDeriving #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE UndecidableInstances #-}

9+module Reflex.Dom.Builder.Hydratable where

10+

11+import Control.Monad.Fix

12+import Control.Monad.Primitive

13+import Control.Monad.Ref

14+import Control.Monad.Trans

15+import Control.Monad.Trans.Control

16+import Data.Coerce

17+import qualified Data.Map as Map

18+import Foreign.JavaScript.TH

19+#ifndef ghcjs_HOST_OS

20+import GHCJS.DOM.Types (MonadJSM (..))

21+#endif

22+import Reflex

23+import Reflex.Dom.Builder.Class

24+import Reflex.Dom.Builder.Immediate (HasDocument (..))

25+import Reflex.Host.Class

26+

27+-- | A DomBuilder transformer that adds "data-ssr" to all elements such that the

28+-- hydration builder knows which bits of DOM were added by us, and which were

29+-- added by external scripts.

30+newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)

31+

32+#ifndef ghcjs_HOST_OS

33+instance MonadJSM m => MonadJSM (HydratableT m) where

34+ liftJSM' = HydratableT . liftJSM'

35+#endif

36+

37+deriving instance MonadSample t m => MonadSample t (HydratableT m)

38+deriving instance MonadHold t m => MonadHold t (HydratableT m)

39+

40+instance MonadTrans HydratableT where

41+ lift = HydratableT

42+

43+instance MonadTransControl HydratableT where

44+ type StT HydratableT a = a

45+ liftWith f = HydratableT $ f runHydratableT

46+ restoreT = HydratableT

47+

48+instance MonadRef m => MonadRef (HydratableT m) where

49+ type Ref (HydratableT m) = Ref m

50+ newRef = lift . newRef

51+ readRef = lift . readRef

52+ writeRef ref = lift . writeRef ref

53+

54+instance PerformEvent t m => PerformEvent t (HydratableT m) where

55+ type Performable (HydratableT m) = Performable m

56+ performEvent_ = lift . performEvent_

57+ performEvent = lift . performEvent

58+

59+instance PrimMonad m => PrimMonad (HydratableT m) where

60+ type PrimState (HydratableT m) = PrimState m

61+ primitive = lift . primitive

62+

63+makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m

64+makeHydratable cfg = cfg

65+ { _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg

66+ , _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg

67+ }

68+

69+instance PostBuild t m => PostBuild t (HydratableT m) where

70+ getPostBuild = lift getPostBuild

71+

72+deriving instance TriggerEvent t m => TriggerEvent t (HydratableT m)

73+

74+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (HydratableT m) where

75+ newEventWithTrigger = lift . newEventWithTrigger

76+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

77+

78+instance Adjustable t m => Adjustable t (HydratableT m) where

79+ runWithReplace a0 a' = HydratableT $ runWithReplace (coerce a0) (coerceEvent a')

80+ traverseDMapWithKeyWithAdjust f dm0 dm' = HydratableT $ traverseDMapWithKeyWithAdjust (\k v -> runHydratableT $ f k v) (coerce dm0) (coerceEvent dm')

81+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = HydratableT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runHydratableT $ f k v) (coerce dm0) (coerceEvent dm')

82+ traverseIntMapWithKeyWithAdjust f m0 m' = HydratableT $ traverseIntMapWithKeyWithAdjust (\k v -> runHydratableT $ f k v) (coerce m0) (coerceEvent m')

83+

84+instance NotReady t m => NotReady t (HydratableT m) where

85+ notReadyUntil = lift . notReadyUntil

86+ notReady = lift notReady

87+

88+instance DomBuilder t m => DomBuilder t (HydratableT m) where

89+ type DomBuilderSpace (HydratableT m) = DomBuilderSpace m

90+ element t cfg = lift . element t (makeHydratable cfg) . runHydratableT

91+ inputElement cfg = lift $ inputElement $ cfg

92+ { _inputElementConfig_elementConfig = makeHydratable $ _inputElementConfig_elementConfig cfg

93+ }

94+ textAreaElement cfg = lift $ textAreaElement $ cfg

95+ { _textAreaElementConfig_elementConfig = makeHydratable $ _textAreaElementConfig_elementConfig cfg

96+ }

97+ selectElement cfg child = do

98+ let cfg' = cfg

99+ { _selectElementConfig_elementConfig = makeHydratable $ _selectElementConfig_elementConfig cfg

100+ }

101+ lift $ selectElement cfg' $ runHydratableT child

102+

103+instance HasDocument m => HasDocument (HydratableT m)

104+

105+instance HasJSContext m => HasJSContext (HydratableT m) where

106+ type JSContextPhantom (HydratableT m) = JSContextPhantom m

107+ askJSContext = lift askJSContext

108+

109+instance HasJS js m => HasJS js (HydratableT m) where

110+ type JSX (HydratableT m) = JSX m

111+ liftJS = lift . liftJS

112+

113+instance DomRenderHook t m => DomRenderHook t (HydratableT m) where

114+ withRenderHook f = HydratableT . withRenderHook f . runHydratableT

115+ requestDomAction = HydratableT . requestDomAction

116+ requestDomAction_ = HydratableT . requestDomAction_

reflex-dom-core/src/Reflex/Dom/Builder/InputDisabled.hs+6

@@ -80,6 +80,7 @@ instance Adjustable t m => Adjustable t (InputDisabledT m) where

80 runWithReplace a0 a' = InputDisabledT $ runWithReplace (coerce a0) (coerceEvent a')

81 traverseDMapWithKeyWithAdjust f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')

82 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')

83+ traverseIntMapWithKeyWithAdjust f m0 m' = InputDisabledT $ traverseIntMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce m0) (coerceEvent m')

84instance NotReady t m => NotReady t (InputDisabledT m) where

85instance NotReady t m => NotReady t (InputDisabledT m) where

85 notReadyUntil = lift . notReadyUntil

86 notReadyUntil = lift . notReadyUntil

@@ -108,3 +109,8 @@ instance HasJSContext m => HasJSContext (InputDisabledT m) where

108instance HasJS js m => HasJS js (InputDisabledT m) where

109instance HasJS js m => HasJS js (InputDisabledT m) where

109 type JSX (InputDisabledT m) = JSX m

110 type JSX (InputDisabledT m) = JSX m

110 liftJS = lift . liftJS

111 liftJS = lift . liftJS

112+

113+instance DomRenderHook t m => DomRenderHook t (InputDisabledT m) where

114+ withRenderHook f = InputDisabledT . withRenderHook f . runInputDisabledT

115+ requestDomAction = InputDisabledT . requestDomAction

116+ requestDomAction_ = InputDisabledT . requestDomAction_

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

@@ -288,7 +288,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

288 StaticDomBuilderT $ do

289 let shouldEscape = elementTag `Set.notMember` noEscapeElements

290 (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing

291− attrs0 <- foldDyn applyMap (Map.insert "data-ssr" "" $ cfg ^. initialAttributes) (cfg ^. modifyAttributes)

291+ attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

292 selectValue <- asks _staticDomBuilderEnv_selectValue

293 let addSelectedAttr attrs sel = case Map.lookup "value" attrs of

294 Just v | v == sel -> attrs <> Map.singleton "selected" ""

reflex-dom-core/src/Reflex/Dom/Core.hs+1

@@ -6,6 +6,7 @@ module Reflex.Dom.Core (module X) where

7import Reflex as X hiding (askEvents)

8import Reflex.Dom.Builder.Class as X

9+import Reflex.Dom.Builder.Hydratable as X

9import Reflex.Dom.Builder.Immediate as X

10import Reflex.Dom.Builder.Immediate as X

10import Reflex.Dom.Builder.InputDisabled as X

11import Reflex.Dom.Builder.InputDisabled as X

11import Reflex.Dom.Builder.Static as X

12import Reflex.Dom.Builder.Static as X

reflex-dom-core/src/Reflex/Dom/Prerender.hs+7−2

@@ -33,6 +33,7 @@ import Foreign.JavaScript.TH

33import GHCJS.DOM.Types (MonadJSM)

34import Reflex hiding (askEvents)

35import Reflex.Dom.Builder.Class

36+import Reflex.Dom.Builder.Hydratable

36import Reflex.Dom.Builder.Immediate

37import Reflex.Dom.Builder.Immediate

37import Reflex.Dom.Builder.InputDisabled

38import Reflex.Dom.Builder.InputDisabled

38import Reflex.Dom.Builder.Static

39import Reflex.Dom.Builder.Static

@@ -283,8 +284,12 @@ instance (Prerender js t m, Monad m, Reflex t, MonadFix m, Group q, Additive q,

283 pure a

284 pure a

284

285

285instance (Prerender js t m, Monad m) => Prerender js t (InputDisabledT m) where

286instance (Prerender js t m, Monad m) => Prerender js t (InputDisabledT m) where

286− type Client (InputDisabledT m) = Client m

287+ type Client (InputDisabledT m) = InputDisabledT (Client m)

287− prerender (InputDisabledT server) client = InputDisabledT $ prerender server client

288+ prerender (InputDisabledT server) (InputDisabledT client) = InputDisabledT $ prerender server client

289+

290+instance (Prerender js t m, Monad m) => Prerender js t (HydratableT m) where

291+ type Client (HydratableT m) = HydratableT (Client m)

292+ prerender (HydratableT server) (HydratableT client) = HydratableT $ prerender server client

288

293

289instance (Prerender js t m, Monad m, ReflexHost t) => Prerender js t (PostBuildT t m) where

294instance (Prerender js t m, Monad m, ReflexHost t) => Prerender js t (PostBuildT t m) where

290 type Client (PostBuildT t m) = PostBuildT t (Client m)

295 type Client (PostBuildT t m) = PostBuildT t (Client m)

reflex-dom-core/test/hydration.hs+1−1

@@ -1347,7 +1347,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do

1347 bodyWidget

1348 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False

1349 putStrLnDebug "rendering static"

1350− ((), html) <- liftIO $ renderStatic staticApp

1350+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp

1351 putStrLnDebug "rendered static"

1352 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run

1353 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover