Implement runWithReplace; use it to implement widgetHoldInternal

src/Foreign/JavaScript/TH.hs

@@ -120,6 +120,7 @@ instance PrimMonad m => PrimMonad (WithWebView x m) where
   primitive = lift . primitive
 
 instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where
+  runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')
   sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
 
 instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

src/Reflex/Dom/Builder/Immediate.hs

@@ -136,6 +136,20 @@ deleteBetweenInclusive s e = do
       _ <- removeChild currentParent $ Just e
       return ()
 
+-- | s and e must both be children of the same node and s must precede e
+deleteBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
+deleteBetweenExclusive s e = do
+  mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
+  case mCurrentParent of
+    Nothing -> return () --TODO: Is this the right behavior?
+    Just currentParent -> do
+      let go = do
+            Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
+            when (toNode s /= toNode x) $ do
+              _ <- removeChild currentParent $ Just x
+              go
+      go
+
 -- | s and e must both be children of the same node and s must precede e; s and all nodes between s and e will be removed, but e will not be removed
 {-# INLINABLE deleteUpTo #-}
 deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
@@ -381,6 +395,24 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
   wrapRawElement = wrap
 
 instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
+  runWithReplace a0 a' = do
+    initialEnv <- ImmediateDomBuilderT ask
+    before <- textNodeInternal ("" :: Text)
+    -- We draw 'after' in this roundabout way to avoid using MonadFix
+    Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
+    let drawInitialChild = do
+          result <- a0
+          append after
+          return result
+    (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
+      Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
+      result <- runImmediateDomBuilderT child $ initialEnv
+        { _immediateDomBuilderEnv_parent = toNode df
+        }
+      deleteBetweenExclusive before after
+      insertBefore df after
+      return result
+    return (result0, result')
   sequenceDMapWithAdjust (dm0 :: DMap k (ImmediateDomBuilderT t m)) dm' = do
     initialEnv <- ImmediateDomBuilderT ask
     let drawChildInitial :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)

src/Reflex/Dom/Builder/InputDisabled.hs

@@ -67,6 +67,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabl
   newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
 
 instance MonadAdjust t m => MonadAdjust t (InputDisabledT m) where
+  runWithReplace a0 a' = InputDisabledT $ runWithReplace (coerce a0) (coerceEvent a')
   sequenceDMapWithAdjust dm0 dm' = InputDisabledT $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
 
 instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

src/Reflex/Dom/Builder/Static.hs

@@ -138,6 +138,11 @@ instance DomSpace StaticDomSpace where
   addEventSpecFlags _ _ _ _ = StaticEventSpec
 
 instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomBuilderT t m) where
+  runWithReplace a0 a' = do
+    (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0) (runStaticDomBuilderT <$> a')
+    o <- hold (snd result0) $ snd <$> result'
+    StaticDomBuilderT $ modify $ (:) $ join o
+    return (fst result0, fst <$> result')
   sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do
     let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v)) dm0
         loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

src/Reflex/Dom/Old.hs

@@ -21,7 +21,6 @@ module Reflex.Dom.Old
        , buildElement
        , buildEmptyElement
        , buildEmptyElementNS
-       , deleteBetweenExclusive
        , elDynHtml'
        , elDynHtmlAttr'
        , elStopPropagationNS
@@ -60,7 +59,7 @@ import Foreign.JavaScript.TH
 import qualified GHCJS.DOM.Element as Element
 import GHCJS.DOM.EventM (EventM)
 import GHCJS.DOM.NamedNodeMap as NNM
-import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild, toNode)
+import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChild)
 import GHCJS.DOM.Types (IsElement, IsNode)
 import qualified GHCJS.DOM.Types as DOM
 import Reflex.Class
@@ -150,20 +149,6 @@ addDynamicAttributes attrs cfg = do
 buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m -> m (Element er (DomBuilderSpace m) t, a)
 buildElementCommon elementTag child cfg = element elementTag cfg child
 
--- | s and e must both be children of the same node and s must precede e
-deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
-deleteBetweenExclusive s e = do
-  mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
-  case mCurrentParent of
-    Nothing -> return () --TODO: Is this the right behavior?
-    Just currentParent -> do
-      let go = do
-            Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
-            when (toNode s /= toNode x) $ do
-              _ <- removeChild currentParent $ Just x
-              go
-      go
-
 onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
 onEventName = elementOnEventName
 

src/Reflex/Dom/Widget/Basic.hs

@@ -91,7 +91,6 @@ import Control.Lens hiding (children, element)
 import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
 import Data.Align
 import Data.Default
-import qualified Data.Dependent.Map as DMap
 import Data.Either
 import Data.Foldable
 import Data.Functor.Misc
@@ -106,15 +105,8 @@ import Data.These
 import Data.Traversable
 import Prelude hiding (mapM, mapM_, sequence, sequence_)
 
---TODO: Implement this specially
 widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
-widgetHoldInternal child0 child' = do
-  (result0, result') <- sequenceDMapWithAdjust (DMap.singleton LeftTag child0) $ fmap (PatchDMap . DMap.insert LeftTag (ComposeMaybe Nothing) . DMap.singleton RightTag . ComposeMaybe . Just) child'
-  let e :: forall x. x
-      e = error "widgetHoldInternal: missing child (should be impossible)"
-  return ( runIdentity $ DMap.findWithDefault e LeftTag result0
-         , ffor result' $ \(PatchDMap p) -> runIdentity $ fromMaybe e $ getComposeMaybe $ DMap.findWithDefault e RightTag p
-         )
+widgetHoldInternal = runWithReplace
 
 -- | Breaks the given Map into pieces based on the given Set.  Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key.  There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.
 -- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.