mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-10-26 15:59:57 +03:00
Implement runWithReplace; use it to implement widgetHoldInternal
This commit is contained in:
parent
b3f0001e77
commit
d308470eb2
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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 $
|
||||
|
@ -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
|
||||
|
||||
|
@ -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.
|
||||
|
Loading…
Reference in New Issue
Block a user