b95a071 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

SSR attr, attempt to fix runWithReplace

b95a071Tom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+42−19

compare with develop

unifiedsplit

@@ -124,10 +124,11 @@ import Data.Some (Some)

124import qualified Data.Some as Some

125import Data.Text (Text)

126import qualified Data.Text as T

127+import Data.Typeable (Typeable, typeRep)

127import GHC.Generics (Generic)

128import GHC.Generics (Generic)

128import qualified GHCJS.DOM as DOM

129import qualified GHCJS.DOM as DOM

129import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

130import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)

130−import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

131+import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)

131import qualified GHCJS.DOM.Element as Element

132import qualified GHCJS.DOM.Element as Element

132import qualified GHCJS.DOM.Event as Event

133import qualified GHCJS.DOM.Event as Event

133import qualified GHCJS.DOM.GlobalEventHandlers as Events

134import qualified GHCJS.DOM.GlobalEventHandlers as Events

@@ -303,20 +304,20 @@ getHydrationMode = do

303

304

304{-# INLINABLE textNodeInternal #-}

305{-# INLINABLE textNodeInternal #-}

305textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Text

306textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Text

306−textNodeInternal !t = makeNodeInternal (askDocument >>= \doc -> liftJSM $ createTextNode doc t) DOM.Text

307+textNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> liftJSM $ createTextNode doc t) DOM.Text

307

308

308{-# INLINABLE commentNodeInternal #-}

309{-# INLINABLE commentNodeInternal #-}

309commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Comment

310commentNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> HydrationDomBuilderT t m DOM.Comment

310−commentNodeInternal !t = makeNodeInternal (askDocument >>= \doc -> liftJSM $ createComment doc t) DOM.Comment

311+commentNodeInternal !t = makeNodeInternal (const $ pure True) (askDocument >>= \doc -> liftJSM $ createComment doc t) DOM.Comment

311

312

312{-# INLINABLE makeNodeInternal #-}

313{-# INLINABLE makeNodeInternal #-}

313−makeNodeInternal :: (MonadJSM m, IsNode node) => HydrationDomBuilderT t m node -> (DOM.JSVal -> node) -> HydrationDomBuilderT t m node

314+makeNodeInternal :: (MonadJSM m, IsNode node, Typeable node) => (node -> HydrationDomBuilderT t m Bool) -> HydrationDomBuilderT t m node -> (DOM.JSVal -> node) -> HydrationDomBuilderT t m node

314−makeNodeInternal mkNode constructor = do

315+makeNodeInternal check mkNode constructor = do

315 doc <- askDocument

316 doc <- askDocument

316 parent <- askParent

317 parent <- askParent

317 getHydrationMode >>= \case

318 getHydrationMode >>= \case

318 HydrationMode_Immediate -> do

319 HydrationMode_Immediate -> do

319− liftIO $ print $ "Not in hydration mode, creating node"

320+ liftIO $ putStrLn $ "Not in hydration mode, creating node: " <> show (typeRep constructor)

320 n <- mkNode

321 n <- mkNode

321 append $ toNode n

322 append $ toNode n

322 return n

323 return n

@@ -329,9 +330,13 @@ makeNodeInternal mkNode constructor = do

329 Nothing -> do

330 Nothing -> do

330 liftIO $ putStrLn $ "Wrong node type, skipping"

331 liftIO $ putStrLn $ "Wrong node type, skipping"

331 go (Just node)

332 go (Just node)

332− Just tn -> do

333+ Just tn -> check tn >>= \case

334+ True -> do

333− liftIO $ print $ "Using existing node"

335+ liftIO $ putStrLn $ "Using existing node"

334− return tn

336+ return tn

337+ False -> do

338+ liftIO $ putStrLn $ "Node failed check, skipping"

339+ go (Just node)

335 n <- go lastHydrationNode

340 n <- go lastHydrationNode

336 liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)

341 liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode n)

337 return n

342 return n

@@ -445,7 +450,6 @@ wrap events e cfg = do

445makeElement :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m) => Text -> ElementConfig er t HydrationDomSpace -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), DOM.Element)

450makeElement :: forall er t m a. (MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, Ref m ~ IORef, PerformEvent t m, MonadJSM (Performable m), MonadRef m) => Text -> ElementConfig er t HydrationDomSpace -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m ((Element er HydrationDomSpace t, a), DOM.Element)

446makeElement elementTag cfg child = do

451makeElement elementTag cfg child = do

447 doc <- askDocument

452 doc <- askDocument

448− parent <- askParent

449 let buildElement = do

453 let buildElement = do

450 e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

454 e <- uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

451 Nothing -> createElement doc elementTag

455 Nothing -> createElement doc elementTag

@@ -454,8 +458,12 @@ makeElement elementTag cfg child = do

454 Nothing -> setAttribute e n v

458 Nothing -> setAttribute e n v

455 Just ans -> setAttributeNS e (Just ans) n v

459 Just ans -> setAttributeNS e (Just ans) n v

456 pure e

460 pure e

461+ ssrAttr = "ssr" :: DOM.JSString

462+ hasSSRAttribute e = case cfg ^. namespace of

463+ Nothing -> hasAttribute e ssrAttr -- TODO: disabled for debugging <* removeAttribute e ssrAttr

464+ Just ns -> hasAttributeNS e (Just ns) ssrAttr -- TODO: disabled for debugging <* removeAttributeNS e (Just ns) ssrAttr

457 -- TODO: prerender needs completely replacing

465 -- TODO: prerender needs completely replacing

458− e <- makeNodeInternal buildElement DOM.Element

466+ e <- makeNodeInternal hasSSRAttribute buildElement DOM.Element

459 -- Run the child builder with updated parent and previous sibling references

467 -- Run the child builder with updated parent and previous sibling references

460 childNode <- liftIO $ newIORef Nothing

468 childNode <- liftIO $ newIORef Nothing

461 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = toNode e, _hydrationDomBuilderEnv_hydrationNode = childNode }) child

469 result <- localEnv (\env -> env { _hydrationDomBuilderEnv_parent = toNode e, _hydrationDomBuilderEnv_hydrationNode = childNode }) child

@@ -467,7 +475,7 @@ makeElement elementTag cfg child = do

467 liftIO $ fire es

475 liftIO $ fire es

468 hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult

476 hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult

469 liftIO $ modifyIORef' hydrationResultRef (beh :)

477 liftIO $ modifyIORef' hydrationResultRef (beh :)

470− collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click))

478+ collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click)) -- TODO! this can't stay here, obviously.

471 let evts = fan collapsed

479 let evts = fan collapsed

472 return ((Element evts (), result), e)

480 return ((Element evts (), result), e)

473

481

@@ -649,7 +657,7 @@ instance SupportsHydrationDomBuilder t m => MountableDomBuilder t (HydrationDomB

649 liftIO $ writeIORef (_hydrationDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

657 liftIO $ writeIORef (_hydrationDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

650 liftIO $ writeIORef (_hydrationDomFragment_state fragment) $ FragmentState_Mounted (before, after)

658 liftIO $ writeIORef (_hydrationDomFragment_state fragment) $ FragmentState_Mounted (before, after)

651

659

652−skipToCommentId :: MonadJSM m => Text -> HydrationDomBuilderT t m (DOM.Comment, Text)

660+skipToCommentId :: MonadJSM m => Text -> HydrationDomBuilderT t m (DOM.Node, Text)

653skipToCommentId prefix = do

661skipToCommentId prefix = do

654 doc <- askDocument

662 doc <- askDocument

655 parent <- askParent

663 parent <- askParent

@@ -672,20 +680,27 @@ skipToCommentId prefix = do

672 go (Just node)

680 go (Just node)

673 (a, key) <- go lastHydrationNode

681 (a, key) <- go lastHydrationNode

674 liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode a)

682 liftIO $ modifyIORef' lastHydrationNodeRef (\_ -> Just $ toNode a)

675− pure (a, key)

683+ pure (toNode a, key)

676

684

677−skipToReplaceStart :: MonadJSM m => HydrationDomBuilderT t m (DOM.Comment, Text)

685+skipToReplaceStart :: MonadJSM m => HydrationDomBuilderT t m (DOM.Node, Text)

678skipToReplaceStart = skipToCommentId "replace-start"

686skipToReplaceStart = skipToCommentId "replace-start"

679

687

680−skipToReplaceEnd :: MonadJSM m => Text -> HydrationDomBuilderT t m DOM.Comment

688+skipToReplaceEnd :: MonadJSM m => Text -> HydrationDomBuilderT t m DOM.Node

681skipToReplaceEnd key = fmap fst $ skipToCommentId $ "replace-end" <> key

689skipToReplaceEnd key = fmap fst $ skipToCommentId $ "replace-end" <> key

682

690

683instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ref m ~ IORef, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m) => Adjustable t (HydrationDomBuilderT t m) where

691instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m, Ref m ~ IORef, PerformEvent t m, MonadReflexCreateTrigger t m, MonadJSM (Performable m), MonadRef m) => Adjustable t (HydrationDomBuilderT t m) where

684 {-# INLINABLE runWithReplace #-}

692 {-# INLINABLE runWithReplace #-}

685 runWithReplace a0 a' = do

693 runWithReplace a0 a' = do

694+ liftIO $ putStrLn "In runWithReplace"

686 initialEnv <- HydrationDomBuilderT ask

695 initialEnv <- HydrationDomBuilderT ask

687− (before, beforeKey) <- skipToReplaceStart

688 let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv

696 let hydrating = _hydrationDomBuilderEnv_hydrationMode initialEnv

697+ initialHydrationMode <- liftIO $ readIORef hydrating

698+ (before, beforeKey) <- case initialHydrationMode of

699+ HydrationMode_Hydrating -> skipToReplaceStart

700+ HydrationMode_Immediate -> do

701+ t <- textNodeInternal ("" :: Text)

702+ append $ toNode t

703+ pure (toNode t, "")

689 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

704 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv

690 haveEverBeenReady <- liftIO $ newIORef False

705 haveEverBeenReady <- liftIO $ newIORef False

691 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM

706 currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM

@@ -701,7 +716,12 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

701 -- We draw 'after' in this roundabout way to avoid using MonadFix

716 -- We draw 'after' in this roundabout way to avoid using MonadFix

702 doc <- askDocument

717 doc <- askDocument

703 parent <- askParent

718 parent <- askParent

719+ after <- case initialHydrationMode of

704− after <- skipToReplaceEnd beforeKey

720+ HydrationMode_Hydrating -> skipToReplaceEnd beforeKey

721+ HydrationMode_Immediate -> do

722+ t <- textNodeInternal ("" :: Text)

723+ append $ toNode t

724+ pure (toNode t)

705 let drawInitialChild = do

725 let drawInitialChild = do

706 liftIO $ putStrLn "drawInitialChild"

726 liftIO $ putStrLn "drawInitialChild"

707 df <- createDocumentFragment doc

727 df <- createDocumentFragment doc

@@ -726,6 +746,7 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

726 df <- createDocumentFragment doc

746 df <- createDocumentFragment doc

727 unreadyChildren <- liftIO $ newIORef 0

747 unreadyChildren <- liftIO $ newIORef 0

728 let commitAction = do

748 let commitAction = do

749+ liftIO $ putStrLn "Committing runWithReplace update"

729 c <- liftIO $ readIORef currentCohort

750 c <- liftIO $ readIORef currentCohort

730 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this

751 when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this

731 deleteBetweenExclusive before after

752 deleteBetweenExclusive before after

@@ -743,7 +764,9 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

743 uc <- liftIO $ readIORef unreadyChildren

764 uc <- liftIO $ readIORef unreadyChildren

744 result <- case h of

765 result <- case h of

745 HydrationMode_Hydrating -> pure Nothing

766 HydrationMode_Hydrating -> pure Nothing

746− HydrationMode_Immediate -> Just <$> child'

767+ HydrationMode_Immediate -> do

768+ liftIO $ putStrLn "Running child in immediate mode"

769+ Just <$> child'

747 let commitActionToRunNow = if uc == 0

770 let commitActionToRunNow = if uc == 0

748 then Just $ commitAction

771 then Just $ commitAction

749 else Nothing -- A child will run it when unreadyChildren is decremented to 0

772 else Nothing -- A child will run it when unreadyChildren is decremented to 0

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

@@ -37,6 +37,7 @@ import Data.Map.Misc (applyMap)

37import Data.Monoid

38import qualified Data.Set as Set

39import Data.Text (Text)

40+import qualified Data.Text as T

40import Data.Text.Encoding

41import Data.Text.Encoding

41import Data.Tuple

42import Data.Tuple

42import GHC.Generics

43import GHC.Generics

@@ -50,6 +51,7 @@ import Reflex.PerformEvent.Base

50import Reflex.PerformEvent.Class

51import Reflex.PerformEvent.Class

51import Reflex.PostBuild.Base

52import Reflex.PostBuild.Base

52import Reflex.TriggerEvent.Class

53import Reflex.TriggerEvent.Class

54+import System.Random (randomRIO)

54data StaticDomBuilderEnv t = StaticDomBuilderEnv

56data StaticDomBuilderEnv t = StaticDomBuilderEnv

55 { _staticDomBuilderEnv_shouldEscape :: Bool

57 { _staticDomBuilderEnv_shouldEscape :: Bool

@@ -155,20 +157,24 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilde

155instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where

157instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where

156 runWithReplace a0 a' = do

158 runWithReplace a0 a' = do

157 e <- StaticDomBuilderT ask

159 e <- StaticDomBuilderT ask

158− replaceStart

160+ key <- replaceStart

159 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

161 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

160 o <- hold (snd result0) $ fmapCheap snd result'

162 o <- hold (snd result0) $ fmapCheap snd result'

161 StaticDomBuilderT $ modify $ (:) $ join o

163 StaticDomBuilderT $ modify $ (:) $ join o

162− replaceEnd

164+ replaceEnd key

163 return (fst result0, fmapCheap fst result')

165 return (fst result0, fmapCheap fst result')

164 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap

166 traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap

165 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

167 traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

166

168

167−replaceStart :: DomBuilder t m => m ()

169+replaceStart :: (DomBuilder t m, MonadIO m) => m Text

170+replaceStart = do

171+ str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')

172+ let key = "-" <> T.pack str

168−replaceStart = void $ commentNode $ def { _commentNodeConfig_initialContents = "replace-start" }

173+ _ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }

174+ pure key

169

175

170−replaceEnd :: DomBuilder t m => m ()

176+replaceEnd :: DomBuilder t m => Text -> m ()

171−replaceEnd = void $ commentNode $ def { _commentNodeConfig_initialContents = "replace-end" }

177+replaceEnd key = void $ commentNode $ def { _commentNodeConfig_initialContents = "replace-end" <> key }

172

178

173hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

179hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

174 ( Adjustable t m

180 ( Adjustable t m

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

238 StaticDomBuilderT $ do

244 StaticDomBuilderT $ do

239 let shouldEscape = elementTag `Set.notMember` noEscapeElements

245 let shouldEscape = elementTag `Set.notMember` noEscapeElements

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

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

241− attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

247+ attrs0 <- foldDyn applyMap (Map.insert "ssr" "" $ cfg ^. initialAttributes) (cfg ^. modifyAttributes)

242 selectValue <- asks _staticDomBuilderEnv_selectValue

248 selectValue <- asks _staticDomBuilderEnv_selectValue

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

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

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

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