@@ -1019,3 +1019,60 @@ wrapWindow wv _ = do
10191019 }
10201020
10211021makeLenses ''GhcjsEventSpec
1022+
1023+data FragmentState
1024+ = FragmentState_Created
1025+ | FragmentState_Mounted (DOM.Text, DOM.Text)
1026+
1027+data DomFragment = DomFragment
1028+ { _domFragment_document :: DOM.DocumentFragment
1029+ , _domFragment_state :: IORef FragmentState
1030+ }
1031+
1032+domFragment :: MonadIO m => ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m (DomFragment, a)
1033+domFragment w = do
1034+ initialEnv <- ImmediateDomBuilderT ask
1035+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
1036+ result <- lift $ runImmediateDomBuilderT w $ initialEnv
1037+ { _immediateDomBuilderEnv_parent = toNode df
1038+ }
1039+ state <- liftIO $ newIORef FragmentState_Created
1040+ return (DomFragment df state, result)
1041+
1042+mountDomFragment :: (PerformEvent t m, MonadIO m, MonadIO (Performable m), MonadFix m, MonadHold t m) => DomFragment -> Event t DomFragment -> ImmediateDomBuilderT t m ()
1043+mountDomFragment fragment setFragment = do
1044+ parent <- askParent
1045+ extractFragment fragment
1046+ mountInBetween <- do
1047+ before <- textNodeInternal ("" :: Text)
1048+ _ <- appendChild parent $ Just $ _domFragment_document fragment
1049+ after <- textNodeInternal ("" :: Text)
1050+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
1051+ performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
1052+ extractFragment previousFragment
1053+ extractFragment childFragment
1054+ insertBefore (_domFragment_document childFragment) after
1055+ liftIO $ writeIORef (_domFragment_state childFragment) $ FragmentState_Mounted (before, after)
1056+ return (before, after)
1057+ liftIO $ writeIORef (_domFragment_state fragment) $ FragmentState_Mounted mountInBetween
1058+
1059+extractFragment :: MonadIO m => DomFragment -> m ()
1060+extractFragment fragment = do
1061+ state <- liftIO $ readIORef $ _domFragment_state fragment
1062+ case state of
1063+ FragmentState_Created -> return ()
1064+ FragmentState_Mounted (before, after) -> do
1065+ extractBetweenExclusive (_domFragment_document fragment) before after
1066+ liftIO $ writeIORef (_domFragment_state fragment) FragmentState_Created
1067+
1068+-- | s and e must both be children of the same node and s must precede e; all
1069+-- nodes between s and e will be moved into the given DocumentFragment, but s
1070+-- and e will not be moved
1071+extractBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
1072+extractBetweenExclusive df s e = go
1073+ where
1074+ go = do
1075+ Just x <- getNextSibling s -- This can't be Nothing because we should hit 'e' first
1076+ when (toNode e /= toNode x) $ do
1077+ _ <- appendChild df $ Just x
1078+ go