8fac38b · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

WIP: Various performance-related tweaks

8fac38bRyan Trinkle9 years ago

reflex-dom-core/src/Foreign/JavaScript/TH.hs+1

compare with develop

unifiedsplit

@@ -138,6 +138,7 @@ instance PrimMonad m => PrimMonad (WithJSContextSingleton x m) where

138

139instance MonadAdjust t m => MonadAdjust t (WithJSContextSingleton x m) where

140 runWithReplace a0 a' = WithJSContextSingleton $ runWithReplace (coerce a0) (coerceEvent a')

141+ traverseIntMapWithKeyWithAdjust f dm0 dm' = WithJSContextSingleton $ traverseIntMapWithKeyWithAdjust (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')

141 traverseDMapWithKeyWithAdjust f dm0 dm' = WithJSContextSingleton $ traverseDMapWithKeyWithAdjust (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')

142 traverseDMapWithKeyWithAdjust f dm0 dm' = WithJSContextSingleton $ traverseDMapWithKeyWithAdjust (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')

142 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = WithJSContextSingleton $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')

143 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = WithJSContextSingleton $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unWithJSContextSingleton $ f k v) (coerce dm0) (coerceEvent dm')

143

144

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+16−12

@@ -163,8 +163,8 @@ class DomBuilder t m => MountableDomBuilder t m where

163type Namespace = Text

164

165data TextNodeConfig t

166− = TextNodeConfig { _textNodeConfig_initialContents :: Text

166+ = TextNodeConfig { _textNodeConfig_initialContents :: {-# UNPACK #-} !Text

167− , _textNodeConfig_setContents :: Maybe (Event t Text)

167+ , _textNodeConfig_setContents :: !(Maybe (Event t Text))

168 }

169

170#ifndef USE_TEMPLATE_HASKELL

@@ -550,15 +550,17 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequesterT

550 textNode = liftTextNode

551 element elementTag cfg (RequesterT child) = RequesterT $ do

552 r <- ask

553+ old <- get

553− (el, (a, e)) <- lift $ lift $ element elementTag cfg $ runReaderT (runEventWriterT child) r

554+ (el, (a, new)) <- lift $ lift $ element elementTag cfg $ runReaderT (runStateT child old) r

554− tellEvent e

555+ put new

555 return (el, a)

556 return (el, a)

556 inputElement = lift . inputElement

557 inputElement = lift . inputElement

557 textAreaElement = lift . textAreaElement

558 textAreaElement = lift . textAreaElement

558 selectElement cfg (RequesterT child) = RequesterT $ do

559 selectElement cfg (RequesterT child) = RequesterT $ do

559 r <- ask

560 r <- ask

561+ old <- get

560− (el, (a, e)) <- lift $ lift $ selectElement cfg $ runReaderT (runEventWriterT child) r

562+ (el, (a, new)) <- lift $ lift $ selectElement cfg $ runReaderT (runStateT child old) r

561− tellEvent e

563+ put new

562 return (el, a)

564 return (el, a)

563 placeRawElement = lift . placeRawElement

565 placeRawElement = lift . placeRawElement

564 wrapRawElement e = lift . wrapRawElement e

566 wrapRawElement e = lift . wrapRawElement e

@@ -566,15 +568,17 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequesterT

566instance (DomBuilder t m, MonadHold t m, MonadFix m, Semigroup w) => DomBuilder t (EventWriterT t w m) where

568instance (DomBuilder t m, MonadHold t m, MonadFix m, Semigroup w) => DomBuilder t (EventWriterT t w m) where

567 type DomBuilderSpace (EventWriterT t w m) = DomBuilderSpace m

569 type DomBuilderSpace (EventWriterT t w m) = DomBuilderSpace m

568 textNode = liftTextNode

570 textNode = liftTextNode

569− element elementTag cfg child = do

571+ element elementTag cfg (EventWriterT child) = EventWriterT $ do

572+ old <- get

570− (el, (a, e)) <- lift $ element elementTag cfg $ runEventWriterT child

573+ (el, (a, new)) <- lift $ element elementTag cfg $ runStateT child old

571− tellEvent e

574+ put new

572 return (el, a)

575 return (el, a)

573 inputElement = lift . inputElement

576 inputElement = lift . inputElement

574 textAreaElement = lift . textAreaElement

577 textAreaElement = lift . textAreaElement

575− selectElement cfg child = do

578+ selectElement cfg (EventWriterT child) = EventWriterT $ do

579+ old <- get

576− (el, (a, e)) <- lift $ selectElement cfg $ runEventWriterT child

580+ (el, (a, new)) <- lift $ selectElement cfg $ runStateT child old

577− tellEvent e

581+ put new

578 return (el, a)

582 return (el, a)

579 placeRawElement = lift . placeRawElement

583 placeRawElement = lift . placeRawElement

580 wrapRawElement e = lift . wrapRawElement e

584 wrapRawElement e = lift . wrapRawElement e

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+193−33

@@ -57,6 +57,8 @@ module Reflex.Dom.Builder.Immediate

57 , phantom2

58#endif

59 , drawChildUpdate

60+ , ChildReadyState (..)

61+ , ChildReadyStateInt (..)

60 , mkHasFocus

62 , mkHasFocus

61 , insertBefore

63 , insertBefore

62 , EventType

64 , EventType

@@ -76,6 +78,11 @@ module Reflex.Dom.Builder.Immediate

76 , WindowConfig (..)

78 , WindowConfig (..)

77 , Window (..)

79 , Window (..)

78 , wrapWindow

80 , wrapWindow

81+ -- * Internal

82+ , traverseDMapWithKeyWithAdjust'

83+ , hoistTraverseWithKeyWithAdjust

84+ , traverseIntMapWithKeyWithAdjust'

85+ , hoistTraverseIntMapWithKeyWithAdjust

79 ) where

86 ) where

81import Foreign.JavaScript.TH

88import Foreign.JavaScript.TH

@@ -152,6 +159,10 @@ import GHCJS.DOM.UIEvent

152import GHCJS.DOM.KeyboardEvent as KeyboardEvent

159import GHCJS.DOM.KeyboardEvent as KeyboardEvent

153import qualified GHCJS.DOM.Window as Window

160import qualified GHCJS.DOM.Window as Window

154import Language.Javascript.JSaddle (call, eval)

161import Language.Javascript.JSaddle (call, eval)

162+import Data.IntMap.Strict (IntMap)

163+import qualified Data.IntMap.Strict as IntMap

164+import Data.FastMutableIntMap (PatchIntMap (..))

165+import qualified Data.FastMutableIntMap as FastMutableIntMap

155

166

156import Reflex.Requester.Base

167import Reflex.Requester.Base

157import Reflex.Requester.Class

168import Reflex.Requester.Class

@@ -165,10 +176,10 @@ instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where

165#endif

176#endif

166

177

167data ImmediateDomBuilderEnv t

178data ImmediateDomBuilderEnv t

168− = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

179+ = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: {-# UNPACK #-} !Document

169− , _immediateDomBuilderEnv_parent :: Node

180+ , _immediateDomBuilderEnv_parent :: {-# UNPACK #-} !Node

170− , _immediateDomBuilderEnv_unreadyChildren :: IORef Word -- Number of children who still aren't fully rendered

181+ , _immediateDomBuilderEnv_unreadyChildren :: {-# UNPACK #-} !(IORef Word) -- Number of children who still aren't fully rendered

171− , _immediateDomBuilderEnv_commitAction :: JSM () -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

182+ , _immediateDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

172 }

183 }

173

184

174newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }

185newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }

@@ -186,11 +197,13 @@ instance MonadTrans (ImmediateDomBuilderT t) where

186 lift = ImmediateDomBuilderT . lift . lift . lift

197 lift = ImmediateDomBuilderT . lift . lift . lift

187

198

188instance (Reflex t, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where

199instance (Reflex t, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where

200+ {-

189 withRenderHook hook (ImmediateDomBuilderT a) = do

201 withRenderHook hook (ImmediateDomBuilderT a) = do

190 e <- ImmediateDomBuilderT ask

202 e <- ImmediateDomBuilderT ask

191 ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do

203 ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do

192 (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp

204 (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp

193− return (ffor req $ \rm -> hook $ DMap.traverseWithKey (\_ r -> Identity <$> r) rm, x)

205+ return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)

206+-}

194 requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity

207 requestDomAction = ImmediateDomBuilderT . lift . requestingIdentity

195 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_

208 requestDomAction_ = ImmediateDomBuilderT . lift . requesting_

196

209

@@ -214,7 +227,7 @@ runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = do

214 win <- DOM.currentWindowUnchecked

227 win <- DOM.currentWindowUnchecked

215 rec (x, req) <- runRequesterT (runReaderT a env) rsp

228 rec (x, req) <- runRequesterT (runReaderT a env) rsp

216 rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame handlersMVar win f $

229 rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame handlersMVar win f $

217− DMap.traverseWithKey (\_ r -> Identity <$> r) rm

230+ traverseRequesterData (\r -> Identity <$> r) rm

218 return x

231 return x

219 where

232 where

220 runInAnimationFrame handlersMVar win f x = do

233 runInAnimationFrame handlersMVar win f x = do

@@ -268,7 +281,7 @@ append n = do

268

281

269{-# INLINABLE textNodeInternal #-}

282{-# INLINABLE textNodeInternal #-}

270textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text

283textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text

271−textNodeInternal t = do

284+textNodeInternal !t = do

272 doc <- askDocument

285 doc <- askDocument

273 n <- liftJSM $ createTextNode doc t

286 n <- liftJSM $ createTextNode doc t

274 append n

287 append n

@@ -340,6 +353,7 @@ collectUpToGivenParent currentParent s e = do

340

353

341newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

354newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

342

355

356+{-# INLINABLE wrap #-}

343wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)

357wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)

344wrap e cfg = do

358wrap e cfg = do

345 events <- askEvents

359 events <- askEvents

@@ -384,7 +398,7 @@ wrap e cfg = do

384 }

398 }

385

399

386{-# INLINABLE makeElement #-}

400{-# INLINABLE makeElement #-}

387−makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)

401+makeElement :: forall er t m a. (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m, PrimMonad m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)

388makeElement elementTag cfg child = do

402makeElement elementTag cfg child = do

389 doc <- askDocument

403 doc <- askDocument

390 e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

404 e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of

@@ -637,6 +651,7 @@ instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomB

637 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

651 liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

638

652

639instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where

653instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where

654+ {-# INLINABLE runWithReplace #-}

640 runWithReplace a0 a' = do

655 runWithReplace a0 a' = do

641 initialEnv <- ImmediateDomBuilderT ask

656 initialEnv <- ImmediateDomBuilderT ask

642 before <- textNodeInternal ("" :: Text)

657 before <- textNodeInternal ("" :: Text)

@@ -692,31 +707,11 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, MonadFix m, Prim

692 return (commitActionToRunNow, result)

707 return (commitActionToRunNow, result)

693 requestDomAction_ $ fmapMaybe fst child'

708 requestDomAction_ $ fmapMaybe fst child'

694 return (result0, snd <$> child')

709 return (result0, snd <$> child')

695− traverseDMapWithKeyWithAdjust = do

710+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

696− let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

711+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjust'

697− let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)

712+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

698− new k (ComposeMaybe m) = ComposeMaybe <$> case m of

713+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjust'

699− Nothing -> return Nothing

714+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

700− Just (Compose (_, _, sRef, _)) -> do

701− readIORef sRef >>= \case

702− ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

703− ChildReadyState_Unready _ -> do

704− writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

705− return $ Just $ Constant sRef

706− delete _ (Constant sRef) = do

707− writeIORef sRef $ ChildReadyState_Unready Nothing

708− return $ Constant ()

709− p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p

710− _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old

711− return $ applyAlways p' old

712− hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do

713− phs <- liftIO $ readIORef placeholders

714− forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do

715− lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

716− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

717− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

718− forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder

719− liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs

720 traverseDMapWithKeyWithAdjustWithMove = do

715 traverseDMapWithKeyWithAdjustWithMove = do

721 let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

716 let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

722 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)

717 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)

@@ -767,6 +762,62 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, MonadFix m, Prim

767 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

762 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

768 liftIO $ writeIORef placeholders $! phsAfter

763 liftIO $ writeIORef placeholders $! phsAfter

769

764

765+{-# INLINABLE traverseDMapWithKeyWithAdjust' #-}

766+traverseDMapWithKeyWithAdjust' :: forall t m (k :: * -> *) v v'. (MonadAdjust t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m, DMap.GCompare k) => (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> ImmediateDomBuilderT t m (DMap k v', Event t (PatchDMap k v'))

767+traverseDMapWithKeyWithAdjust' = do

768+ let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

769+ let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)

770+ new k (ComposeMaybe m) = ComposeMaybe <$> case m of

771+ Nothing -> return Nothing

772+ Just (Compose (_, _, sRef, _)) -> do

773+ readIORef sRef >>= \case

774+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

775+ ChildReadyState_Unready _ -> do

776+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

777+ return $ Just $ Constant sRef

778+ delete _ (Constant sRef) = do

779+ writeIORef sRef $ ChildReadyState_Unready Nothing

780+ return $ Constant ()

781+ p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p

782+ _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old

783+ return $ applyAlways p' old

784+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do

785+ phs <- liftIO $ readIORef placeholders

786+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do

787+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

788+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

789+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

790+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder

791+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs

792+

793+{-# INLINABLE traverseIntMapWithKeyWithAdjust' #-}

794+traverseIntMapWithKeyWithAdjust' :: forall t m v v'. (MonadAdjust t m, MonadHold t m, MonadFix m, MonadIO m, MonadJSM m, PrimMonad m) => (IntMap.Key -> v -> ImmediateDomBuilderT t m v') -> IntMap v -> Event t (PatchIntMap v) -> ImmediateDomBuilderT t m (IntMap v', Event t (PatchIntMap v'))

795+traverseIntMapWithKeyWithAdjust' = do

796+ let updateChildUnreadiness (p@(PatchIntMap pInner) :: PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) old = do

797+ let new :: IntMap.Key -> Maybe (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IO (Maybe (IORef ChildReadyStateInt))

798+ new k m = case m of

799+ Nothing -> return Nothing

800+ Just (_, _, sRef, _) -> do

801+ readIORef sRef >>= \case

802+ ChildReadyStateInt_Ready -> return Nothing -- Delete this child, since it's ready

803+ ChildReadyStateInt_Unready _ -> do

804+ writeIORef sRef $ ChildReadyStateInt_Unready $ Just k

805+ return $ Just sRef

806+ delete _ sRef = do

807+ writeIORef sRef $ ChildReadyStateInt_Unready Nothing

808+ return ()

809+ p' <- fmap PatchIntMap $ IntMap.traverseWithKey new pInner

810+ _ <- IntMap.traverseWithKey delete $ FastMutableIntMap.getDeletions p old

811+ return $ applyAlways p' old

812+ hoistTraverseIntMapWithKeyWithAdjust traverseIntMapWithKeyWithAdjust updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchIntMap p) -> do

813+ phs <- liftIO $ readIORef placeholders

814+ forM_ (IntMap.toList p) $ \(k, mv) -> do

815+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

816+ let nextPlaceholder = maybe lastPlaceholder snd $ IntMap.lookupGT k phs

817+ forM_ (IntMap.lookup k phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

818+ forM_ mv $ \(df, _, _, _) -> df `insertBefore` nextPlaceholder

819+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (fmap (\(_, ph, _, _) -> ph) $ PatchIntMap p) phs

820+

770#if MIN_VERSION_base(4,9,0)

821#if MIN_VERSION_base(4,9,0)

771data ChildReadyState k

822data ChildReadyState k

772#else

823#else

@@ -776,6 +827,95 @@ data ChildReadyState (k :: * -> *)

776 | ChildReadyState_Unready !(Maybe (Some k))

827 | ChildReadyState_Unready !(Maybe (Some k))

777 deriving (Show, Read, Eq, Ord)

828 deriving (Show, Read, Eq, Ord)

778

829

830+data ChildReadyStateInt

831+ = ChildReadyStateInt_Ready

832+ | ChildReadyStateInt_Unready !(Maybe Int)

833+ deriving (Show, Read, Eq, Ord)

834+

835+{-# INLINE hoistTraverseIntMapWithKeyWithAdjust #-}

836+hoistTraverseIntMapWithKeyWithAdjust :: forall v v' t m p.

837+ ( MonadAdjust t m

838+ , MonadIO m

839+ , MonadJSM m

840+ , PrimMonad m

841+ , Monoid (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

842+ , Functor p

843+ )

844+ => ( (IntMap.Key -> v -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))

845+ -> IntMap v

846+ -> Event t (p v)

847+ -> RequesterT t JSM Identity (TriggerEventT t m) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event t (p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))

848+ ) -- ^ The base monad's traversal

849+ -> (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

850+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM

851+ -> (IntMap.Key -> v -> ImmediateDomBuilderT t m v')

852+ -> IntMap v

853+ -> Event t (p v)

854+ -> ImmediateDomBuilderT t m (IntMap v', Event t (p v'))

855+hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_ f dm0 dm' = do

856+ initialEnv <- ImmediateDomBuilderT ask

857+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

858+ pendingChange :: IORef (IntMap (IORef ChildReadyStateInt), p (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')) <- liftIO $ newIORef mempty

859+ haveEverBeenReady <- liftIO $ newIORef False

860+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"

861+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"

862+ let applyDomUpdate p = do

863+ applyDomUpdate_ placeholders lastPlaceholderRef p

864+ markSelfReady

865+ liftIO $ writeIORef pendingChange $! mempty

866+ markSelfReady = do

867+ liftIO (readIORef haveEverBeenReady) >>= \case

868+ True -> return ()

869+ False -> do

870+ liftIO $ writeIORef haveEverBeenReady True

871+ old <- liftIO $ readIORef parentUnreadyChildren

872+ let new = pred old

873+ liftIO $ writeIORef parentUnreadyChildren $! new

874+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

875+ markChildReady :: IORef ChildReadyStateInt -> JSM ()

876+ markChildReady childReadyState = do

877+ liftIO (readIORef childReadyState) >>= \case

878+ ChildReadyStateInt_Ready -> return ()

879+ ChildReadyStateInt_Unready countedAt -> do

880+ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready

881+ case countedAt of

882+ Nothing -> return ()

883+ Just k -> do -- This child has been counted as unready, so we need to remove it from the unready set

884+ (oldUnready, p) <- liftIO $ readIORef pendingChange

885+ when (not $ IntMap.null oldUnready) $ do -- This shouldn't actually ever be null

886+ let newUnready = IntMap.delete k oldUnready

887+ liftIO $ writeIORef pendingChange (newUnready, p)

888+ when (IntMap.null newUnready) $ do

889+ applyDomUpdate p

890+ (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

891+ let processChild k (_, _, sRef, _) = do

892+ readIORef sRef >>= \case

893+ ChildReadyStateInt_Ready -> return Nothing

894+ ChildReadyStateInt_Unready _ -> do

895+ writeIORef sRef $ ChildReadyStateInt_Unready $ Just k

896+ return $ Just sRef

897+ initialUnready <- liftIO $ IntMap.mapMaybe id <$> IntMap.traverseWithKey processChild children0

898+ liftIO $ if IntMap.null initialUnready

899+ then writeIORef haveEverBeenReady True

900+ else do

901+ modifyIORef' parentUnreadyChildren succ

902+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

903+ let result0 = IntMap.map (\(_, _, _, v) -> v) children0

904+ placeholders0 = fmap (\(_, ph, _, _) -> ph) children0

905+ result' = ffor children' $ fmap $ \(_, _, _, r) -> r

906+ liftIO $ writeIORef placeholders $! placeholders0

907+ _ <- IntMap.traverseWithKey (\_ (df, _, _, _) -> void $ append df) children0

908+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

909+ requestDomAction_ $ ffor children' $ \p -> do

910+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange

911+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready

912+ let !newP = p <> oldP

913+ liftIO $ writeIORef pendingChange (newUnready, newP)

914+ when (IntMap.null newUnready) $ do

915+ applyDomUpdate newP

916+ return (result0, result')

917+

918+{-# INLINABLE hoistTraverseWithKeyWithAdjust #-}

779hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

919hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

780 ( MonadAdjust t m

920 ( MonadAdjust t m

781 , MonadHold t m

921 , MonadHold t m

@@ -865,6 +1005,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

865 applyDomUpdate newP

1005 applyDomUpdate newP

866 return (result0, result')

1006 return (result0, result')

867

1007

1008+{-# INLINABLE drawChildUpdate #-}

868drawChildUpdate :: (MonadIO m, MonadJSM m)

1009drawChildUpdate :: (MonadIO m, MonadJSM m)

869 => ImmediateDomBuilderEnv t

1010 => ImmediateDomBuilderEnv t

870 -> (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

1011 -> (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

@@ -883,6 +1024,25 @@ drawChildUpdate initialEnv markReady child = do

883 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

1024 when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

884 return $ Compose (df, placeholder, childReadyState, result)

1025 return $ Compose (df, placeholder, childReadyState, result)

885

1026

1027+{-# INLINABLE drawChildUpdateInt #-}

1028+drawChildUpdateInt :: (MonadIO m, MonadJSM m)

1029+ => ImmediateDomBuilderEnv t

1030+ -> (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

1031+ -> ImmediateDomBuilderT t m v'

1032+ -> RequesterT t JSM Identity (TriggerEventT t m) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')

1033+drawChildUpdateInt initialEnv markReady child = do

1034+ childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing

1035+ unreadyChildren <- liftIO $ newIORef 0

1036+ df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

1037+ (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1038+ { _immediateDomBuilderEnv_parent = toNode df

1039+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

1040+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState

1041+ }

1042+ u <- liftIO $ readIORef unreadyChildren

1043+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyStateInt_Ready

1044+ return (df, placeholder, childReadyState, result)

1045+

886mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

1046mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

887mkHasFocus e = do

1047mkHasFocus e = do

888 let initialFocus = False --TODO: Actually get the initial focus of the element

1048 let initialFocus = False --TODO: Actually get the initial focus of the element

reflex-dom-core/src/Reflex/Dom/Main.hs+3−6

@@ -44,12 +44,9 @@ import GHCJS.DOM.NonElementParentNode

44import GHCJS.DOM.Types (JSM)

45import qualified GHCJS.DOM.Types as DOM

47−{-# INLINABLE mainWidget #-}

47+{-# INLINE mainWidget #-}

48mainWidget :: (forall x. Widget x ()) -> JSM ()

49−mainWidget w = withJSContextSingleton $ \jsSing -> do

49+mainWidget = mainWidget'

50− doc <- currentDocumentUnchecked

51− body <- getBodyUnchecked doc

52− attachWidget body jsSing w

54{-# INLINABLE mainWidget' #-}

51{-# INLINABLE mainWidget' #-}

55-- | Warning: `mainWidget'` is provided only as performance tweak. It is expected to disappear in future releases.

52-- | Warning: `mainWidget'` is provided only as performance tweak. It is expected to disappear in future releases.

@@ -78,7 +75,7 @@ mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do

78 body <- getBodyUnchecked doc

75 body <- getBodyUnchecked doc

79 attachWidget body jsSing w

76 attachWidget body jsSing w

81−type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithJSContextSingleton x (PerformEventT Spider (SpiderHost Global)))) --TODO: Make this more abstract --TODO: Put the WithJSContext underneath PerformEventT - I think this would perform better

78+type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithJSContextSingleton x (PerformEventT Spider (SpiderHost Global)))) --TODO: Make this more abstract --TODO: Put the WithJSContext underneath PerformEventT - I think this would perform better because it could avoid fmapping over every performEvent

83{-# INLINABLE attachWidget #-}

80{-# INLINABLE attachWidget #-}

84attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

81attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

reflex-dom-core/src/Reflex/Dom/Modals/Base.hs+4−1

@@ -9,6 +9,8 @@

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11module Reflex.Dom.Modals.Base

12+where

13+{-

12 ( ModalsT (..)

14 ( ModalsT (..)

13 , ModalLayerConfig (..)

15 , ModalLayerConfig (..)

14 , withModalLayer

16 , withModalLayer

@@ -102,7 +104,7 @@ instance MonadAtomicRef m => MonadAtomicRef (ModalsT t m) where

102 {-# INLINABLE atomicModifyRef #-}

104 {-# INLINABLE atomicModifyRef #-}

103 atomicModifyRef r = lift . atomicModifyRef r

105 atomicModifyRef r = lift . atomicModifyRef r

104

106

105−instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (ModalsT t m) where

107+instance (MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (ModalsT t m) where

106 runWithReplace a0 a' = ModalsT $ runWithReplace (unModalsT a0) (fmapCheap unModalsT a')

108 runWithReplace a0 a' = ModalsT $ runWithReplace (unModalsT a0) (fmapCheap unModalsT a')

107 traverseDMapWithKeyWithAdjust f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjust (coerce f) dm0 dm'

109 traverseDMapWithKeyWithAdjust f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjust (coerce f) dm0 dm'

108 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjustWithMove (coerce f) dm0 dm'

110 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjustWithMove (coerce f) dm0 dm'

@@ -192,3 +194,4 @@ modalBody cfg v = do

192 [ Just <$> complete

194 [ Just <$> complete

193 , Nothing <$ domEvent Click overlay

195 , Nothing <$ domEvent Click overlay

194 ]

196 ]

197+-}