@@ -112,6 +112,7 @@ import Control.Monad.Primitive
112112import Control.Monad.Reader
113113import Control.Monad.Ref
114114import Control.Monad.State.Strict
115+import Control.Monad.Trans.Maybe
115116#ifndef USE_TEMPLATE_HASKELL
116117import Data.Functor.Contravariant (phantom)
117118#endif
@@ -1077,11 +1078,11 @@ traverseIntMapWithKeyWithAdjust'
10771078 -> Event t (PatchIntMap v)
10781079 -> HydrationDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))
10791080traverseIntMapWithKeyWithAdjust' = do
1080− let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
1081− let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
1081+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do
1082+ let new :: IntMap.Key -> Maybe (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))
10821083 new k m = case m of
10831084 Nothing -> return Nothing
1084− Just (_, _, sRef, _) -> do
1085+ Just (_, _, _, sRef, _) -> do
10851086 readIORef sRef >>= \case
10861087 ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready
10871088 ChildReadyStateInt_Unready _ -> do
@@ -1099,8 +1100,8 @@ traverseIntMapWithKeyWithAdjust' = do
10991100 lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
11001101 let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs
11011102 forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
1102− forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder
1103− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, ph, _, _) -> ph) <$> PatchIntMap p) phs
1103+ forM_ mv $ \(_, df, _, _, _) -> df `insertBefore` nextPlaceholder
1104+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply ((\(_, _, ph, _, _) -> ph) <$> PatchIntMap p) phs
11041105
11051106{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}
11061107hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
@@ -1109,16 +1110,19 @@ hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.
11091110 , MonadJSM m
11101111 , MonadFix m
11111112 , PrimMonad m
1112− , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1113+ , Monoid (p (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
11131114 , Functor p
1115+ , PatchTarget (p (DOM t m)) ~ IntMap (DOM t m)
1116+ , MonadHold t m
1117+ , Patch (p (DOM t m))
11141118 )
1115− => ( (IntMap.Key -> v -> DomRenderHookT t m (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
1119+ => ( (IntMap.Key -> v -> DomRenderHookT t m (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
11161120 -> IntMap v
11171121 -> Event t (p v)
1118− -> DomRenderHookT t m (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
1122+ -> DomRenderHookT t m (IntMap (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
11191123 ) -- ^ The base monad's traversal
1120− -> (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1121− -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
1124+ -> (p (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
1125+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
11221126 -> (IntMap.Key -> v -> HydrationDomBuilderT t m v')
11231127 -> IntMap v
11241128 -> Event t (p v)
@@ -1127,7 +1131,7 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
11271131 (hydrateStart, _, key) <- skipToReplaceStart
11281132 initialEnv <- HydrationDomBuilderT ask
11291133 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
1130− pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
1134+ pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty
11311135 haveEverBeenReady <- liftIO $ newIORef False
11321136 placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
11331137 lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
@@ -1159,10 +1163,8 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
11591163 liftIO $ writeIORef pendingChange (newUnready, p)
11601164 when (IntMap.null newUnready) $ do
11611165 applyDomUpdate p
1162− stateRef <- liftIO . newIORef =<< HydrationDomBuilderT get
1163− (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdateInt stateRef initialEnv markChildReady $ f k v) dm0 dm'
1164− HydrationDomBuilderT . put =<< liftIO (readIORef stateRef)
1165− let processChild k (_, _, sRef, _) = do
1166+ (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'
1167+ let processChild k (_, _, _, sRef, _) = do
11661168 readIORef sRef >>= \case
11671169 ChildReadyStateInt_Ready -> return Nothing
11681170 ChildReadyStateInt_Unready _ -> do
@@ -1174,12 +1176,27 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
11741176 else do
11751177 modifyIORef' parentUnreadyChildren succ
11761178 writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
1177− let result0 = IntMap.map (\(_, _, _, v) -> v) children0
1178− placeholders0 = fmap (\(_, ph, _, _) -> ph) children0
1179− result' = ffor children' $ fmap $ \(_, _, _, r) -> r
1179+ let result0 = IntMap.map (\(_, _, _, _, v) -> v) children0
1180+ placeholders0 = fmap (\(_, _, ph, _, _) -> ph) children0
1181+ delayed0 :: IntMap (DOM t m)
1182+ delayed0 = IntMap.map (\(delayed, _, _, _, _) -> delayed) children0
1183+ delayed' :: Event t (p (DOM t m))
1184+ delayed' = ffor children' $ fmap $ \(delayed, _, _, _, _) -> delayed
1185+ result' = ffor children' $ fmap $ \(_, _, _, _, r) -> r
1186+ delayed <- accumMaybeB (flip apply) delayed0 delayed'
1187+ doc <- askDocument
1188+ let setFinalPlaceholder = do
1189+ ph <- createTextNode doc ("" :: Text)
1190+ parent <- askParent
1191+ pn <- runMaybeT $ MaybeT . Node.getNextSibling =<< MaybeT getPreviousNode
1192+ Node.insertBefore_ parent ph pn
1193+ liftIO $ writeIORef lastPlaceholderRef ph
1194+ setPreviousNode $ Just $ toNode ph
1195+ hydrateDOM $ DOM_Replace (pure ()) setFinalPlaceholder
1196+ (reverse . IntMap.elems <$> delayed)
11801197 liftIO $ writeIORef placeholders $! placeholders0
11811198 getHydrationMode >>= \case
1182− HydrationMode_Immediate -> void $ IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append $ toNode df) children0
1199+ HydrationMode_Immediate -> void $ IntMap.traverseWithKey (\_ (_, df, _, _, _) -> void $ append $ toNode df) children0
11831200 _ -> pure ()
11841201 (hydrateEnd, lastPlaceholderRef) <- skipToReplaceEnd key
11851202 requestDomAction_ $ ffor children' $ \p -> do
@@ -1191,13 +1208,6 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_
11911208 applyDomUpdate newP
11921209 return (result0, result')
11931210
1194−-- traverseDMapWithKeyWithAdjust
1195−-- :: GCompare k
1196−-- => (forall a. k a -> v a -> m (v' a))
1197−-- -> DMap k v
1198−-- -> Event t (PatchDMap k v)
1199−-- -> m (DMap k v', Event t (PatchDMap k v'))
1200−
12011211{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}
12021212hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
12031213 ( Adjustable t m
@@ -1228,7 +1238,7 @@ hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
12281238 -> Event t (p k v)
12291239 -> HydrationDomBuilderT t m (DMap k v', Event t (p k v'))
12301240hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> HydrationDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
1231− (hydrateStart, _, key) <- skipToReplaceStart
1241+-- (hydrateStart, _, key) <- skipToReplaceStart -- TODO
12321242 initialEnv <- HydrationDomBuilderT ask
12331243 let parentUnreadyChildren = _hydrationDomBuilderEnv_unreadyChildren initialEnv
12341244 pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,,) (DOM t m) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
@@ -1264,7 +1274,6 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
12641274 when (DMap.null newUnready) $ do
12651275 applyDomUpdate p
12661276 (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
1267−-- HydrationDomBuilderT . put =<< liftIO (readIORef stateRef)
12681277 let processChild k (Compose (_, _, _, sRef, _)) = ComposeMaybe <$> do
12691278 readIORef sRef >>= \case
12701279 ChildReadyState_Ready -> return Nothing
@@ -1285,13 +1294,20 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda
12851294 delayed' = ffor children' $ mapPatch $ \(Compose (d, _, _, _, _)) -> Const d
12861295 result' = ffor children' $ mapPatch $ \(Compose (_, _, _, _, r)) -> r
12871296 delayed <- accumMaybeB (flip apply) delayed0 delayed'
1288− hydrateDOM $ DOM_Replace (liftIO $ putStr "one") (liftIO $ putStr "two")
1289− (fmap (\(_ :=> Const d) -> d) . DMap.toList <$> delayed)
1297+ doc <- askDocument
1298+ let setFinalPlaceholder = do
1299+ ph <- createTextNode doc ("" :: Text)
1300+ parent <- askParent
1301+ pn <- runMaybeT $ MaybeT . Node.getNextSibling =<< MaybeT getPreviousNode
1302+ Node.insertBefore_ parent ph pn
1303+ liftIO $ writeIORef lastPlaceholderRef ph
1304+ setPreviousNode $ Just $ toNode ph
1305+ hydrateDOM $ DOM_Replace (pure ()) setFinalPlaceholder
1306+ (fmap (\(_ :=> Const d) -> d) . reverse . DMap.toList <$> delayed)
12901307 liftIO $ writeIORef placeholders $! placeholders0
12911308 getHydrationMode >>= \case
12921309 HydrationMode_Immediate -> void $ DMap.traverseWithKey (\_ (Compose (_, df, _, _, _)) -> Constant () <$ append (toNode df)) children0
12931310 _ -> pure ()
1294− (hydrateEnd, lastPlaceholderRef) <- skipToReplaceEnd key
12951311 requestDomAction_ $ ffor children' $ \p -> do
12961312 (oldUnready, oldP) <- liftIO $ readIORef pendingChange
12971313 newUnready <- liftIO $ updateChildUnreadiness p oldUnready
@@ -1313,18 +1329,20 @@ drawChildUpdate initialEnv markReady child = do
13131329 unreadyChildren <- liftIO $ newIORef 0
13141330 hydrationMode <- liftIO $ readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv
13151331 placeholder <- createTextNode doc ("" :: Text)
1316− p <- case hydrationMode of
1317− HydrationMode_Hydrating -> do
1318− let p = _hydrationDomBuilderEnv_parent initialEnv
1319− p' <- liftIO $ readIORef p
1320−-- case _hydrationState_previousNode initialState of
1321−-- Nothing -> Node.appendChild_ p' placeholder
1322−-- Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ p' placeholder
1323− pure (Left p)
1332+ (p, delayed) <- case hydrationMode of
1333+ HydrationMode_Hydrating -> pure
1334+ ( Left $ _hydrationDomBuilderEnv_parent initialEnv
1335+ , do
1336+ parent <- askParent
1337+ getPreviousNode >>= \case
1338+ Nothing -> Node.getFirstChild parent >>= Node.insertBefore_ parent placeholder
1339+ Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ parent placeholder
1340+ setPreviousNode $ Just $ toNode placeholder
1341+ )
13241342 HydrationMode_Immediate -> do
13251343 df <- createDocumentFragment doc
13261344 Node.appendChild_ df placeholder
1327− pure (Right df)
1345+ pure (Right df, pure ())
13281346 p' <- either pure (liftIO . newIORef . toNode) p
13291347 (result, finalState) <- flip runStateT [] $ runReaderT (unHydrationDomBuilderT child) initialEnv
13301348 { _hydrationDomBuilderEnv_parent = p'
@@ -1334,48 +1352,50 @@ drawChildUpdate initialEnv markReady child = do
13341352 u <- liftIO $ readIORef unreadyChildren
13351353 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
13361354 return $ Compose
1337− ( DOM_Replace (liftIO $ putStrLn "before") (liftIO $ putStrLn "after") $ pure finalState
1355+ ( DOM_Replace delayed (pure ()) (pure finalState)
13381356 , either (const $ error "drawChildUpdate: Tried to use document fragment in hydration mode") id p
13391357 , placeholder, childReadyState, result
13401358 )
13411359
13421360{-# INLINABLE drawChildUpdateInt #-}
1343−drawChildUpdateInt :: (MonadIO m, MonadJSM m)
1344− => IORef [DOM t m]
1345− -> HydrationDomBuilderEnv
1361+drawChildUpdateInt :: (MonadIO m, MonadJSM m, Reflex t)
1362+ => HydrationDomBuilderEnv
13461363 -> (IORef ChildReadyStateInt -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
13471364 -> HydrationDomBuilderT t m v'
1348− -> DomRenderHookT t m (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
1349−drawChildUpdateInt stateRef initialEnv markReady child = do
1365+ -> DomRenderHookT t m (DOM t m, DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')
1366+drawChildUpdateInt initialEnv markReady child = do
13501367 childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing
13511368 let doc = _hydrationDomBuilderEnv_document initialEnv
13521369 unreadyChildren <- liftIO $ newIORef 0
13531370 hydrationMode <- liftIO $ readIORef $ _hydrationDomBuilderEnv_hydrationMode initialEnv
1354− initialState <- liftIO $ readIORef stateRef
13551371 placeholder <- createTextNode doc ("" :: Text)
1356− p <- case hydrationMode of
1357− HydrationMode_Hydrating -> do
1358− let p = _hydrationDomBuilderEnv_parent initialEnv
1359− p' <- liftIO $ readIORef p
1360−-- case _hydrationState_previousNode initialState of
1361−-- Nothing -> Node.appendChild_ p' placeholder
1362−-- Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ p' placeholder
1363− pure (Left p)
1372+ (p, delayed) <- case hydrationMode of
1373+ HydrationMode_Hydrating -> pure
1374+ ( Left $ _hydrationDomBuilderEnv_parent initialEnv
1375+ , do
1376+ parent <- askParent
1377+ getPreviousNode >>= \case
1378+ Nothing -> Node.getFirstChild parent >>= Node.insertBefore_ parent placeholder
1379+ Just pn -> Node.getNextSibling pn >>= Node.insertBefore_ parent placeholder
1380+ setPreviousNode $ Just $ toNode placeholder
1381+ )
13641382 HydrationMode_Immediate -> do
13651383 df <- createDocumentFragment doc
13661384 Node.appendChild_ df placeholder
1367− pure (Right df)
1385+ pure (Right df, pure ())
13681386 p' <- either pure (liftIO . newIORef . toNode) p
1369− let env = initialEnv
1387+ (result, finalState) <- flip runStateT [] $ runReaderT (unHydrationDomBuilderT child) initialEnv
13701388 { _hydrationDomBuilderEnv_parent = p'
13711389 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren
13721390 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState
13731391 }
1374− (result, finalState) <- runStateT (runReaderT (unHydrationDomBuilderT child) env) initialState --{ _hydrationState_previousNode = Just $ toNode placeholder })
1375− liftIO $ writeIORef stateRef finalState
13761392 u <- liftIO $ readIORef unreadyChildren
13771393 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready
1378− return (either (const $ error "drawChildUpdateInt: Tried to use document fragment in hydration mode") id p, placeholder, childReadyState, result)
1394+ return
1395+ ( DOM_Replace delayed (pure ()) (pure finalState)
1396+ , either (const $ error "drawChildUpdateInt: Tried to use document fragment in hydration mode") id p
1397+ , placeholder, childReadyState, result
1398+ )
13791399
13801400mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
13811401mkHasFocus e = do
@@ -1393,9 +1413,7 @@ insertAfter new existing = do
13931413
13941414insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
13951415insertBefore new existing = do
1396− liftIO $ putStrLn "insertBefore"
13971416 p <- getParentNodeUnchecked existing
1398− liftIO $ putStrLn "insertBefore2"
13991417 DOM.insertBefore_ p new (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
14001418
14011419instance PerformEvent t m => PerformEvent t (HydrationDomBuilderT t m) where