git.iko.soy/reflex-dom
on develop help sign in
Merge branch 'fragments-only' into jsaddle
6244fa6Ryan Trinkle
reflex-dom-core/src/Foreign/JavaScript/TH.hs+1−1
compare with develop
unifiedsplit
@@ -178,7 +178,7 @@ instance MonadTransControl (WithJSContextSingleton x) where
178 restoreT = defaultRestoreT WithJSContextSingleton
178 restoreT = defaultRestoreT WithJSContextSingleton
179
179
180instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where
180instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where
181− type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)
181+ type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m) --TODO: Can we eliminate this wrapper?
182 {-# INLINABLE performEvent_ #-}
182 {-# INLINABLE performEvent_ #-}
183 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
183 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
184 {-# INLINABLE performEvent #-}
184 {-# INLINABLE performEvent #-}
reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+24
@@ -149,6 +149,25 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), MonadAdjust t m) => DomB
149 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
149 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
150 }
150 }
151 {-# INLINABLE wrapRawElement #-}
151 {-# INLINABLE wrapRawElement #-}
152+ notReadyUntil :: Event t a -> m ()
153+ default notReadyUntil :: ( MonadTrans f
154+ , m ~ f m'
155+ , DomBuilder t m'
156+ )
157+ => Event t a -> m ()
158+ notReadyUntil = lift . notReadyUntil
159+ notReady :: m ()
160+ default notReady :: ( MonadTrans f
161+ , m ~ f m'
162+ , DomBuilder t m'
163+ )
164+ => m ()
165+ notReady = lift notReady
166+
167+class DomBuilder t m => MountableDomBuilder t m where
168+ type DomFragment m :: *
169+ buildDomFragment :: m a -> m (DomFragment m, a)
170+ mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m ()
152
171
153type Namespace = Text
172type Namespace = Text
154
173
@@ -512,6 +531,11 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui
512 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m
531 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m
513 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg
532 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg
514
533
534+instance (MountableDomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => MountableDomBuilder t (PostBuildT t m) where
535+ type DomFragment (PostBuildT t m) = DomFragment m
536+ buildDomFragment = liftThrough buildDomFragment
537+ mountDomFragment f0 f' = lift $ mountDomFragment f0 f'
538+
515instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
539instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
516 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
540 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
517 textNode = liftTextNode
541 textNode = liftTextNode
reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+302−81
@@ -5,6 +5,7 @@
5{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE EmptyDataDecls #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
@@ -83,6 +84,8 @@ import Reflex.Class as Reflex
83import Reflex.Dom.Builder.Class
84import Reflex.Dom.Builder.Class
84import Reflex.Dynamic
85import Reflex.Dynamic
85import Reflex.Host.Class
86import Reflex.Host.Class
87+import qualified Reflex.Patch.DMap as PatchDMap
88+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
86import Reflex.PerformEvent.Class
89import Reflex.PerformEvent.Class
87import Reflex.PostBuild.Class
90import Reflex.PostBuild.Class
88import Reflex.TriggerEvent.Base hiding (askEvents)
91import Reflex.TriggerEvent.Base hiding (askEvents)
@@ -105,10 +108,12 @@ import Data.Dependent.Sum
105import Data.Functor.Compose
108import Data.Functor.Compose
106import Data.Functor.Constant
109import Data.Functor.Constant
107import Data.Functor.Misc
110import Data.Functor.Misc
111+import Data.Functor.Product
108import Data.IORef
112import Data.IORef
109import qualified Data.Map as Map
113import qualified Data.Map as Map
110import Data.Maybe
114import Data.Maybe
111−import Data.Monoid
115+import Data.Monoid hiding (Product)
116+import Data.Some (Some)
112import qualified Data.Some as Some
117import qualified Data.Some as Some
113import Data.Text (Text)
118import Data.Text (Text)
114import qualified Data.Text as T
119import qualified Data.Text as T
@@ -142,13 +147,15 @@ import Reflex.Requester.Class
142
147
143data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
148data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
144
149
145−data ImmediateDomBuilderEnv t m
150+data ImmediateDomBuilderEnv t
146 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
151 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
147 , _immediateDomBuilderEnv_parent :: Node
152 , _immediateDomBuilderEnv_parent :: Node
148 , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
153 , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]
154+ , _immediateDomBuilderEnv_unreadyChildren :: IORef Word -- Number of children who still aren't fully rendered
155+ , _immediateDomBuilderEnv_commitAction :: JSM () -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it
149 }
156 }
150
157
151−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t m) (RequesterT t JSM Identity m) a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
158+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity m) a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
152
159
153#ifndef __GHCJS__
160#ifndef __GHCJS__
154instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
161instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
@@ -172,7 +179,7 @@ instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilder
172 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
179 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_
173
180
174{-# INLINABLE runImmediateDomBuilderT #-}
181{-# INLINABLE runImmediateDomBuilderT #-}
175−runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t m -> m a
182+runImmediateDomBuilderT :: (Reflex t, MonadFix m, PerformEvent t m, MonadJSM (Performable m)) => ImmediateDomBuilderT t m a -> ImmediateDomBuilderEnv t -> m a
176runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do
183runImmediateDomBuilderT (ImmediateDomBuilderT a) env = do
177 rec (x, req) <- runRequesterT (runReaderT a env) rsp
184 rec (x, req) <- runRequesterT (runReaderT a env) rsp
178 rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
185 rsp <- performEvent $ ffor req $ \rm -> liftJSM $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm
@@ -274,9 +281,9 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR
274wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
281wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
275wrap e cfg = do
282wrap e cfg = do
276 events <- askEvents
283 events <- askEvents
277− mapM_ (requestDomAction_ . fmap (imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
284+ forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
278 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
285 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
279− Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv)) (_rawElementConfig_modifyAttributes cfg)
286+ Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
280 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
287 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
281 triggerRef <- liftIO $ newIORef Nothing
288 triggerRef <- liftIO $ newIORef Nothing
282 _ <- elementOnEventName en e $ do
289 _ <- elementOnEventName en e $ do
@@ -309,13 +316,16 @@ wrap e cfg = do
309 --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
316 --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
310 ref <- newIORef $ Just t
317 ref <- newIORef $ Just t
311 writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
318 writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
312− return $ Element es e
319+ return $ Element
320+ { _element_events = es
321+ , _element_raw = e
322+ }
313
323
314{-# INLINABLE makeElement #-}
324{-# INLINABLE makeElement #-}
315makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
325makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
316makeElement elementTag cfg child = do
326makeElement elementTag cfg child = do
317− doc <- askDocument
318 env <- ImmediateDomBuilderT ask
327 env <- ImmediateDomBuilderT ask
328+ let doc = _immediateDomBuilderEnv_document env
319 e <- liftJSM $ case cfg ^. namespace of
329 e <- liftJSM $ case cfg ^. namespace of
320 Nothing -> createElementUnchecked doc (Just elementTag)
330 Nothing -> createElementUnchecked doc (Just elementTag)
321 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
331 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
@@ -507,96 +517,307 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
507 return (wrapped, result)
517 return (wrapped, result)
508 placeRawElement = append
518 placeRawElement = append
509 wrapRawElement = wrap
519 wrapRawElement = wrap
520+ notReadyUntil e = do
521+ eOnce <- headE e
522+ env <- ImmediateDomBuilderT ask
523+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
524+ liftIO $ modifyIORef' unreadyChildren succ
525+ let ready = do
526+ old <- liftIO $ readIORef unreadyChildren
527+ let new = pred old
528+ liftIO $ writeIORef unreadyChildren $! new
529+ when (new == 0) $ _immediateDomBuilderEnv_commitAction env
530+ requestDomAction_ $ ready <$ eOnce
531+ notReady = do
532+ env <- ImmediateDomBuilderT ask
533+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env
534+ liftIO $ modifyIORef' unreadyChildren succ
535+
536+data FragmentState
537+ = FragmentState_Unmounted
538+ | FragmentState_Mounted (DOM.Text, DOM.Text)
539+
540+data ImmediateDomFragment = ImmediateDomFragment
541+ { _immediateDomFragment_document :: DOM.DocumentFragment
542+ , _immediateDomFragment_state :: IORef FragmentState
543+ }
544+
545+extractFragment :: MonadJSM m => ImmediateDomFragment -> m ()
546+extractFragment fragment = do
547+ state <- liftIO $ readIORef $ _immediateDomFragment_state fragment
548+ case state of
549+ FragmentState_Unmounted -> return ()
550+ FragmentState_Mounted (before, after) -> do
551+ extractBetweenExclusive (_immediateDomFragment_document fragment) before after
552+ liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
553+
554+instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
555+ type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
556+ buildDomFragment w = do
557+ initialEnv <- ImmediateDomBuilderT ask
558+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
559+ result <- lift $ runImmediateDomBuilderT w $ initialEnv
560+ { _immediateDomBuilderEnv_parent = toNode df
561+ }
562+ state <- liftIO $ newIORef FragmentState_Unmounted
563+ return (ImmediateDomFragment df state, result)
564+ mountDomFragment fragment setFragment = do
565+ parent <- askParent
566+ extractFragment fragment
567+ before <- textNodeInternal ("" :: Text)
568+ appendChild_ parent $ Just $ _immediateDomFragment_document fragment
569+ after <- textNodeInternal ("" :: Text)
570+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
571+ performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
572+ extractFragment previousFragment
573+ extractFragment childFragment
574+ insertBefore (_immediateDomFragment_document childFragment) after
575+ liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
576+ liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
510
577
511instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where
578instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where
512 runWithReplace a0 a' = do
579 runWithReplace a0 a' = do
513 initialEnv <- ImmediateDomBuilderT ask
580 initialEnv <- ImmediateDomBuilderT ask
514 before <- textNodeInternal ("" :: Text)
581 before <- textNodeInternal ("" :: Text)
582+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
583+ haveEverBeenReady <- liftIO $ newIORef False
584+ let myCommitAction = do
585+ liftIO (readIORef haveEverBeenReady) >>= \case
586+ True -> return ()
587+ False -> do
588+ liftIO $ writeIORef haveEverBeenReady True
589+ old <- liftIO $ readIORef parentUnreadyChildren
590+ let new = pred old
591+ liftIO $ writeIORef parentUnreadyChildren $! new
592+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
515 -- We draw 'after' in this roundabout way to avoid using MonadFix
593 -- We draw 'after' in this roundabout way to avoid using MonadFix
516 after <- createTextNodeUnchecked (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
594 after <- createTextNodeUnchecked (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
517 let drawInitialChild = do
595 let drawInitialChild = do
596+ unreadyChildren <- liftIO $ newIORef 0
597+ let f = do
518− result <- a0
598+ result <- a0
519− append after
599+ append after
600+ return result
601+ result <- runImmediateDomBuilderT f $ initialEnv
602+ { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
603+ , _immediateDomBuilderEnv_commitAction = myCommitAction
604+ }
605+ liftIO $ readIORef unreadyChildren >>= \case
606+ 0 -> writeIORef haveEverBeenReady True
607+ _ -> modifyIORef' parentUnreadyChildren succ
520 return result
608 return result
609+ currentCohort <- liftIO $ newIORef (0 :: Int)
610+ a'' <- numberOccurrences a'
521− (result0, result') <- ImmediateDomBuilderT $ lift $ runWithReplace (runReaderT (unImmediateDomBuilderT drawInitialChild) initialEnv) $ ffor a' $ \child -> do
611+ (result0, result') <- lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do
522 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
612 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
613+ unreadyChildren <- liftIO $ newIORef 0
614+ let commitAction = do
615+ c <- liftIO $ readIORef currentCohort
616+ when (c < cohortId) $ do -- If a newer cohort has already been committed, just ignore this
617+ deleteBetweenExclusive before after
618+ insertBefore df after
619+ liftIO $ writeIORef currentCohort cohortId
620+ myCommitAction
523− result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv
621+ result <- runImmediateDomBuilderT child $ initialEnv
524 { _immediateDomBuilderEnv_parent = toNode df
622 { _immediateDomBuilderEnv_parent = toNode df
623+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
624+ , _immediateDomBuilderEnv_commitAction = commitAction
525 }
625 }
526− let update = do
626+
527− deleteBetweenExclusive before after
627+ liftIO (readIORef unreadyChildren) >>= \case
528− insertBefore df after
628+ 0 -> liftJSM commitAction
529− return (result, update)
629+ _ -> return () -- Whoever decrements it to 0 will handle it
530− requestDomAction_ $ snd <$> result'
630+ return result
531− return (result0, fst <$> result')
532− traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
533− initialEnv <- ImmediateDomBuilderT ask
534− (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
535− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
536− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
537− result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r
538− placeholders' = fforCheap children' $ weakenPatchDMapWith $ \(Compose (_, ph, _)) -> ph
539− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
540− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
541− lastPlaceholder <- textNodeInternal ("" :: Text)
542− requestDomAction_ $ flip push children' $ \(PatchDMap p) -> do
543− phs <- sample placeholders
544− if DMap.null p then return Nothing else return $ Just $ do
545− let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> JSM ()
546− g (k :=> ComposeMaybe mv) = do
547− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
548− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
549− forM_ mv $ \(Compose (df, _, _)) -> df `insertBefore` nextPlaceholder
550− mapM_ g $ DMap.toList p
551 return (result0, result')
631 return (result0, result')
552− traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
632+ traverseDMapWithKeyWithAdjust = do
553− initialEnv <- ImmediateDomBuilderT ask
633+ let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
554− (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'
634+ let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)
555− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0
635+ new k (ComposeMaybe m) = ComposeMaybe <$> case m of
556− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0
636+ Nothing -> return Nothing
557− result' = ffor children' $ mapPatchDMapWithMove $ \(Compose (_, _, r)) -> r
637+ Just (Compose (_, _, sRef, _)) -> do
558− placeholders' = fforCheap children' $ weakenPatchDMapWithMoveWith $ \(Compose (_, ph, _)) -> ph
638+ readIORef sRef >>= \case
559− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
639+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready
560− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0
640+ ChildReadyState_Unready _ -> do
561− lastPlaceholder <- textNodeInternal ("" :: Text)
641+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
562− requestDomAction_ $ flip push children' $ \p_ -> do
642+ return $ Just $ Constant sRef
643+ delete _ (Constant sRef) = do
644+ writeIORef sRef $ ChildReadyState_Unready Nothing
645+ return $ Constant ()
646+ p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p
647+ _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old
648+ return $ applyAlways p' old
649+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do
650+ phs <- liftIO $ readIORef placeholders
651+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do
652+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
653+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
654+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
655+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder
656+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs
657+ traverseDMapWithKeyWithAdjustWithMove = do
658+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do
659+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)
660+ new k = PatchDMapWithMove.nodeInfoMapFromM $ \case
661+ PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do
662+ readIORef sRef >>= \case
663+ ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete
664+ ChildReadyState_Unready _ -> do
665+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
666+ return $ PatchDMapWithMove.From_Insert $ Constant sRef
667+ PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete
668+ PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey
669+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)
670+ deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do
671+ writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases
672+ return $ Constant ()
673+ p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p
674+ _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old
675+ return $ applyAlways p' old
676+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do
563 let p = unPatchDMapWithMove p_
677 let p = unPatchDMapWithMove p_
564− phsBefore <- sample placeholders
678+ phsBefore <- liftIO $ readIORef placeholders
565− if DMap.null p then return Nothing else return $ Just $ do
679+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef
566− let collectIfMoved :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
680+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)
567− collectIfMoved k e = do
681+ collectIfMoved k e = do
568− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
682+ let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before
569− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
683+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore
570− case dmapEditMoved e of
684+ case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of
571− False -> do
685+ False -> do
572− mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
686+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder
573− return $ Constant Nothing
687+ return $ Constant Nothing
574− True -> do
688+ True -> do
575− Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
689+ Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder
576− collected <- DMap.traverseWithKey collectIfMoved p
690+ collected <- DMap.traverseWithKey collectIfMoved p
577− let phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
691+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this
578− let placeFragment :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant () a)
692+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)
579− placeFragment k e = do
693+ placeFragment k e = do
580− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
694+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter
581− case e of
695+ case PatchDMapWithMove._nodeInfo_from e of
582− DMapEdit_Insert _ (Compose (df, _, _)) -> do
696+ PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do
583− df `insertBefore` nextPlaceholder
697+ df `insertBefore` nextPlaceholder
584− DMapEdit_Delete _ -> do
698+ PatchDMapWithMove.From_Delete -> do
585− return ()
699+ return ()
586− DMapEdit_Move _ fromKey -> do
700+ PatchDMapWithMove.From_Move fromKey -> do
587− Just (Constant mdf) <- return $ DMap.lookup fromKey collected
701+ Just (Constant mdf) <- return $ DMap.lookup fromKey collected
588− mapM_ (`insertBefore` nextPlaceholder) mdf
702+ mapM_ (`insertBefore` nextPlaceholder) mdf
589− return $ Constant ()
703+ return $ Constant ()
590− mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time
704+ mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time
591− return ()
705+ liftIO $ writeIORef placeholders $! phsAfter
592− return (result0, result')
706+
593−
707+data ChildReadyState k
708+ = ChildReadyState_Ready
709+ | ChildReadyState_Unready !(Maybe (Some k))
710+ deriving (Show, Read, Eq, Ord)
711+
712+hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
713+ ( PerformEvent t m
714+ , MonadAdjust t m
715+ , MonadHold t m
716+ , DMap.GCompare k
717+ , MonadIO (Performable m)
718+ , MonadIO m
719+ , MonadJSM m
720+ , PrimMonad m
721+ , MonadFix m
722+ , Patch (p k v)
723+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)
724+ , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))
725+ , Patch (p k (Constant Int))
726+ )
727+ => (forall vv vv'.
728+ (forall a. k a -> vv a -> RequesterT t JSM Identity m (vv' a))
729+ -> DMap k vv
730+ -> Event t (p k vv)
731+ -> RequesterT t JSM Identity m (DMap k vv', Event t (p k vv'))
732+ ) -- ^ The base monad's traversal
733+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
734+ -> (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
735+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM
736+ -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))
737+ -> DMap k v
738+ -> Event t (p k v)
739+ -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))
740+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do
741+ initialEnv <- ImmediateDomBuilderT ask
742+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv
743+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty
744+ haveEverBeenReady <- liftIO $ newIORef False
745+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"
746+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"
747+ let applyDomUpdate = applyDomUpdate_ placeholders lastPlaceholderRef
748+ let markSelfReady = do
749+ liftIO (readIORef haveEverBeenReady) >>= \case
750+ True -> return ()
751+ False -> do
752+ liftIO $ writeIORef haveEverBeenReady True
753+ old <- liftIO $ readIORef parentUnreadyChildren
754+ let new = pred old
755+ liftIO $ writeIORef parentUnreadyChildren $! new
756+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv
757+ markChildReady :: IORef (ChildReadyState k) -> JSM ()
758+ markChildReady childReadyState = do
759+ liftIO (readIORef childReadyState) >>= \case
760+ ChildReadyState_Ready -> return ()
761+ ChildReadyState_Unready countedAt -> do
762+ liftIO $ writeIORef childReadyState ChildReadyState_Ready
763+ case countedAt of
764+ Nothing -> return ()
765+ Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set
766+ (oldUnready, p) <- liftIO $ readIORef pendingChange
767+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null
768+ let newUnready = DMap.delete k oldUnready
769+ liftIO $ writeIORef pendingChange (newUnready, p)
770+ when (DMap.null newUnready) $ do
771+ applyDomUpdate p
772+ markSelfReady
773+ (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'
774+ let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do
775+ readIORef sRef >>= \case
776+ ChildReadyState_Ready -> return Nothing
777+ ChildReadyState_Unready _ -> do
778+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k
779+ return $ Just $ Constant sRef
780+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0
781+ liftIO $ if DMap.null initialUnready
782+ then writeIORef haveEverBeenReady True
783+ else do
784+ modifyIORef' parentUnreadyChildren succ
785+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time
786+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0
787+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0
788+ result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r
789+ liftIO $ writeIORef placeholders $! placeholders0
790+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0
791+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)
792+ -- Note: the numbering here must match the numbering of dm''
793+ requestDomAction_ $ ffor children' $ \p -> do
794+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange
795+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready
796+ let !newP = p <> oldP
797+ liftIO $ writeIORef pendingChange (newUnready, newP)
798+ when (DMap.null newUnready) $ do
799+ applyDomUpdate newP
800+ markSelfReady
801+ liftIO $ writeIORef pendingChange $! mempty
802+ return (result0, result')
803+
804+drawChildUpdate :: (MonadIO m, MonadJSM m)
805+ => ImmediateDomBuilderEnv t
806+ -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready
807+ -> ImmediateDomBuilderT t m (v' a)
594−drawChildUpdate :: (MonadJSM m, PerformEvent t m, MonadFix m, MonadJSM (Performable m)) => ImmediateDomBuilderEnv t m -> ImmediateDomBuilderT t m (v' a) -> RequesterT t JSM Identity m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)
808+ -> RequesterT t JSM Identity m (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)
595−drawChildUpdate initialEnv child = do
809+drawChildUpdate initialEnv markReady child = do
810+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing
811+ unreadyChildren <- liftIO $ newIORef 0
596 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
812 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
597− runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv
813+ (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv
598 { _immediateDomBuilderEnv_parent = toNode df
814 { _immediateDomBuilderEnv_parent = toNode df
815+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
816+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState
599 }
817 }
818+ u <- liftIO $ readIORef unreadyChildren
819+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready
820+ return $ Compose (df, placeholder, childReadyState, result)
600
821
601mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
822mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
602mkHasFocus e = do
823mkHasFocus e = do
reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+44−16
@@ -150,21 +150,43 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomB
150 o <- hold (snd result0) $ fmapCheap snd result'
150 o <- hold (snd result0) $ fmapCheap snd result'
151 StaticDomBuilderT $ modify $ (:) $ join o
151 StaticDomBuilderT $ modify $ (:) $ join o
152 return (fst result0, fmapCheap fst result')
152 return (fst result0, fmapCheap fst result')
153− traverseDMapWithKeyWithAdjust f (dm0 :: DMap k v) dm' = do
153+ traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
154+ traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
155+
156+hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.
157+ ( MonadAdjust t m
158+ , MonadHold t m
159+ , DMap.GCompare k
160+ , Patch (p k v)
161+ , PatchTarget (p k (Constant (Behavior t Builder))) ~ DMap k (Constant (Behavior t Builder))
162+ , Patch (p k (Constant (Behavior t Builder)))
163+ )
164+ => (forall vv vv'.
165+ (forall a. k a -> vv a -> m (vv' a))
166+ -> DMap k vv
167+ -> Event t (p k vv)
168+ -> m (DMap k vv', Event t (p k vv'))
169+ ) -- ^ The base monad's traversal
170+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type
171+ -> (forall a. k a -> v a -> StaticDomBuilderT t m (v' a))
172+ -> DMap k v
173+ -> Event t (p k v)
174+ -> StaticDomBuilderT t m (DMap k v', Event t (p k v'))
175+hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do
154− e <- StaticDomBuilderT ask
176+ e <- StaticDomBuilderT ask
155− (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'
177+ (children0, children') <- lift $ base (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'
156− let result0 = DMap.map (snd . getCompose) children0
178+ let result0 = DMap.map (snd . getCompose) children0
157− result' = ffor children' $ mapPatchDMap $ snd . getCompose
179+ result' = ffor children' $ mapPatch $ snd . getCompose
158− outputs0 :: DMap k (Constant (Behavior t Builder))
180+ outputs0 :: DMap k (Constant (Behavior t Builder))
159− outputs0 = DMap.map (Constant . fst . getCompose) children0
181+ outputs0 = DMap.map (Constant . fst . getCompose) children0
160− outputs' :: Event t (PatchDMap k (Constant (Behavior t Builder)))
182+ outputs' :: Event t (p k (Constant (Behavior t Builder)))
161− outputs' = ffor children' $ mapPatchDMap $ Constant . fst . getCompose
183+ outputs' = ffor children' $ mapPatch $ Constant . fst . getCompose
162− outputs <- holdIncremental outputs0 outputs'
184+ outputs <- holdIncremental outputs0 outputs'
163− StaticDomBuilderT $ modify $ (:) $ pull $ do
185+ StaticDomBuilderT $ modify $ (:) $ pull $ do
164− os <- sample $ currentIncremental outputs
186+ os <- sample $ currentIncremental outputs
165− fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do
187+ fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do
166− sample o
188+ sample o
167− return (result0, result')
189+ return (result0, result')
168
190
169-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.
191-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.
170instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where
192instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where
@@ -204,7 +226,11 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
204 let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]
226 let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]
205 let close = constant $ byteString $ "</" <> tagBS <> ">"
227 let close = constant $ byteString $ "</" <> tagBS <> ">"
206 modify $ (:) $ mconcat [open, innerHtml, close]
228 modify $ (:) $ mconcat [open, innerHtml, close]
207− return (Element es (), result)
229+ let e = Element
230+ { _element_events = es
231+ , _element_raw = ()
232+ }
233+ return (e, result)
208 {-# INLINABLE inputElement #-}
234 {-# INLINABLE inputElement #-}
209 inputElement cfg = do
235 inputElement cfg = do
210 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
236 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
@@ -250,6 +276,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
250 return (wrapped, result)
276 return (wrapped, result)
251 placeRawElement () = return ()
277 placeRawElement () = return ()
252 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()
278 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()
279+ notReadyUntil _ = return () --TODO: Do we need to support this somehow?
280+ notReady = return () --TODO: Do we need to support this somehow?
253
281
254--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
282--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
255type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))
283type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))
reflex-dom-core/src/Reflex/Dom/Main.hs+6
@@ -90,10 +90,13 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do
90 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
90 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
91 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c
91 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c
92 go w df = do
92 go w df = do
93+ unreadyChildren <- liftIO $ newIORef 0
93 let builderEnv = ImmediateDomBuilderEnv
94 let builderEnv = ImmediateDomBuilderEnv
94 { _immediateDomBuilderEnv_document = toDocument doc
95 { _immediateDomBuilderEnv_document = toDocument doc
95 , _immediateDomBuilderEnv_parent = toNode df
96 , _immediateDomBuilderEnv_parent = toNode df
96 , _immediateDomBuilderEnv_events = events
97 , _immediateDomBuilderEnv_events = events
98+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
99+ , _immediateDomBuilderEnv_commitAction = return () --TODO
97 }
100 }
98 runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing
101 runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing
99 rec b <- go (headWidget a) headFragment
102 rec b <- go (headWidget a) headFragment
@@ -116,10 +119,13 @@ attachWidget' rootElement jsSing w = do
116 df <- createDocumentFragmentUnchecked doc
119 df <- createDocumentFragmentUnchecked doc
117 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
120 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do
118 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
121 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
122+ unreadyChildren <- liftIO $ newIORef 0
119 let builderEnv = ImmediateDomBuilderEnv
123 let builderEnv = ImmediateDomBuilderEnv
120 { _immediateDomBuilderEnv_document = toDocument doc
124 { _immediateDomBuilderEnv_document = toDocument doc
121 , _immediateDomBuilderEnv_parent = toNode df
125 , _immediateDomBuilderEnv_parent = toNode df
122 , _immediateDomBuilderEnv_events = events
126 , _immediateDomBuilderEnv_events = events
127+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren
128+ , _immediateDomBuilderEnv_commitAction = return () --TODO
123 }
129 }
124 a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing
130 a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing
125 return ((a, events), postBuildTriggerRef)
131 return ((a, events), postBuildTriggerRef)
reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+7−3
@@ -144,6 +144,7 @@ dynText t = do
144 [ updated t
144 [ updated t
145 , tag (current t) postBuild
145 , tag (current t) postBuild
146 ]
146 ]
147+ notReadyUntil postBuild
147
148
148display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
149display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
149display = dynText . fmap (T.pack . show)
150display = dynText . fmap (T.pack . show)
@@ -161,7 +162,7 @@ dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
161dyn child = do
162dyn child = do
162 postBuild <- getPostBuild
163 postBuild <- getPostBuild
163 let newChild = leftmost [updated child, tagCheap (current child) postBuild]
164 let newChild = leftmost [updated child, tagCheap (current child) postBuild]
164− snd <$> widgetHoldInternal (return ()) newChild
165+ snd <$> widgetHoldInternal notReady newChild
165
166
166-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
167-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
167-- The returned Dynamic of widget results occurs when the Event does.
168-- The returned Dynamic of widget results occurs when the Event does.
@@ -341,8 +342,11 @@ elDynAttrNS' mns elementTag attrs child = do
341 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
342 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
342 let cfg = def
343 let cfg = def
343 & elementConfig_namespace .~ mns
344 & elementConfig_namespace .~ mns
344− & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
345+ & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs
345− element elementTag cfg child
346+ result <- element elementTag cfg child
347+ postBuild <- getPostBuild
348+ notReadyUntil postBuild
349+ return result
346
350
347dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
351dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
348dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty
352dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty
test/prebuild.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+import Control.Monad
9+import Control.Monad.Trans
10+import Reflex.Dom
11+import qualified Data.Text as T
12+import Control.Concurrent
13+
14+import Control.Monad.State.Strict
15+import Data.Functor.Misc
16+import Data.Monoid
17+import Data.Word
18+import qualified Data.Map as Map
19+import qualified Data.Dependent.Map as DMap
20+import Data.Dependent.Sum
21+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
22+
23+main :: IO ()
24+main = mainWidget w
25+
26+w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()
27+w = do
28+ let slow :: forall m'. MonadWidget t m' => m' ()
29+ {-
30+ performEventChain = do
31+ postBuild <- delay 0 =<< getPostBuild
32+ rec let maxN = 10000
33+ n = leftmost [0 <$ postBuild, ffilter (<=maxN) $ succ <$> n']
34+ n' <- performEvent $ return <$> n
35+ pausedUntil $ ffilter (==maxN) n'
36+ _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
37+ return ()
38+ -}
39+ {- Many dyns
40+ slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
41+ where maxDepth = 6 :: Int
42+ go 0 = blank
43+ go n = void $ dyn $ pure $ do
44+ let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"
45+ s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor
46+ elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n
47+ elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
48+ elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
49+ elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
50+ -}
51+ {- Many elDynAttrs
52+ slow = do
53+ let size = 64
54+ replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do
55+ replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank
56+ -}
57+ {- Many dynTexts
58+ slow = el "table" $ do
59+ let size = 64
60+ replicateM_ size $ el "tr" $ do
61+ replicateM_ size $ el "td" $ do
62+ dynText $ pure "."
63+ -}
64+ {- Many simultaneous performEvents
65+ slow = do
66+ postBuild <- getPostBuild
67+ replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
68+ done <- performEvent $ return () <$ postBuild
69+ _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
70+ return ()
71+ -}
72+ {-
73+ slow = do
74+ postBuild <- getPostBuild
75+ postBuild' <- performEvent . (return () <$) =<< performEvent . (return () <$) =<< getPostBuild
76+ let f x = Map.fromList [(n, x) | n <- [1 :: Int .. 4096]]
77+ listHoldWithKey (f False) (f (Just True) <$ postBuild') $ \k -> \case
78+ False -> do
79+ text "X "
80+ notReadyUntil =<< getPostBuild
81+ True -> do
82+ text ". "
83+ return ()
84+ -}
85+ slow = do
86+ let f :: forall a. EitherTag () () a -> Const2 () () a -> m' (Const2 () () a)
87+ f _ (Const2 ()) = do
88+ notReadyUntil =<< delay 0.5 =<< getPostBuild
89+ text "Done"
90+ return $ Const2 ()
91+ postBuild <- getPostBuild
92+ traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild
93+ return ()
94+ el "div" $ do
95+ draw <- button "Draw"
96+ widgetHold blank $ ffor draw $ \_ -> do
97+ postBuild <- getPostBuild
98+ widgetHold (text "Loading...") $ slow <$ postBuild
99+ return ()
100+ return ()
101+
102+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
103+instance {-# INCOHERENT #-} (Show (f a), Show (f b)) => ShowTag (EitherTag a b) f where
104+ showTagToShow e _ = case e of
105+ LeftTag -> id
106+ RightTag -> id
107+#endif