300ef93 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add scheduleFollowup; should fix the listWithKey timing bug

commit300ef932c9320a46f7612c6b2c34b9e87116f36d authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 24 Jul 2015, 14:51 (11 years ago) parente580cfd

3 files changed+47−9

compare with develop

unifiedsplit

src/Reflex/Dom/Class.hs+12 src/Reflex/Dom/Internal.hs+28−2 src/Reflex/Dom/Widget/Basic.hs+7−7

src/Reflex/Dom/Class.hs+12

@@ -13,6 +13,7 @@ import Data.Foldable

1313import Control.Monad.Ref

1414import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence)

1515import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)

16+import qualified Control.Monad.State.Strict as Strict hiding (mapM, mapM_, forM, forM_, sequence)

1617import Data.Dependent.Sum (DSum (..))

1718import GHCJS.DOM.Types hiding (Event)

1819import GHCJS.DOM (WebView)

@@ -73,6 +74,10 @@ instance HasWebView m => HasWebView (StateT r m) where

7374 type WebViewPhantom (StateT r m) = WebViewPhantom m

7475 askWebView = lift askWebView

7576

77+instance HasWebView m => HasWebView (Strict.StateT r m) where

78+ type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m

79+ askWebView = lift askWebView

80+

7681newtype Restore m = Restore { restore :: forall a. m a -> IO a }

7782

7883class Monad m => MonadIORestore m where

@@ -87,6 +92,7 @@ instance MonadIORestore m => MonadIORestore (ReaderT r m) where

8792class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where

8893 askPostGui :: m (h () -> IO ())

8994 askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())

95+ scheduleFollowup :: Ref m (Maybe (EventTrigger t a)) -> a -> m ()

9096

9197runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()

9298runFrameWithTriggerRef r a = do

@@ -97,6 +103,12 @@ runFrameWithTriggerRef r a = do

97103instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where

98104 askPostGui = lift askPostGui

99105 askRunWithActions = lift askRunWithActions

106+ scheduleFollowup r a = lift $ scheduleFollowup r a

107+

108+instance HasPostGui t h m => HasPostGui t h (Strict.StateT s m) where

109+ askPostGui = lift askPostGui

110+ askRunWithActions = lift askRunWithActions

111+ scheduleFollowup r a = lift $ scheduleFollowup r a

100112

101113instance MonadWidget t m => MonadWidget t (ReaderT r m) where

102114 type WidgetHost (ReaderT r m) = WidgetHost m

src/Reflex/Dom/Internal.hs+28−2

@@ -29,12 +29,17 @@ import Data.Traversable

2929import qualified Data.Text as T

3030import Data.Text.Encoding

3131import Data.Monoid ((<>))

32+import Data.IORef

33+import Data.Maybe

34+

35+newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

3236

3337data GuiEnv t h x

3438 = GuiEnv { _guiEnvDocument :: !HTMLDocument

3539 , _guiEnvPostGui :: !(h () -> IO ())

3640 , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())

3741 , _guiEnvWebView :: !(WebViewSingleton x)

42+ , _guiEnvFollowupEvents :: Ref h [DSum (EventTriggerRef t h)]

3843 }

3944

4045--TODO: Poorly named

@@ -102,10 +107,14 @@ instance HasWebView m => HasWebView (Widget t m) where

102107instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h x m) where

103108 askPostGui = Gui $ view guiEnvPostGui

104109 askRunWithActions = Gui $ view guiEnvRunWithActions

110+ scheduleFollowup r a = Gui $ do

111+ followupEventsRef <- view guiEnvFollowupEvents

112+ modifyRef' followupEventsRef $ ((EventTriggerRef r :=> a) :)

105113

106114instance HasPostGui t h m => HasPostGui t h (Widget t m) where

107115 askPostGui = lift askPostGui

108116 askRunWithActions = lift askRunWithActions

117+ scheduleFollowup r a = lift $ scheduleFollowup r a

109118

110119type WidgetInternal t m a = ReaderT WidgetEnv (StateT (WidgetState t m) m) a

111120

@@ -215,10 +224,12 @@ instance HasPostGui t h m => HasPostGui t (WithWebView x h) (WithWebView x m) wh

215224 askRunWithActions = do

216225 runWithActions <- lift askRunWithActions

217226 return $ lift . runWithActions

227+ scheduleFollowup r a = lift $ scheduleFollowup r a

218228

219229instance HasPostGui Spider SpiderHost SpiderHost where

220230 askPostGui = return $ \h -> liftIO $ runSpiderHost h

221231 askRunWithActions = return fireEvents

232+ scheduleFollowup _ _ = liftIO $ putStrLn "scheduleFollowup{Spider,SpiderHost,SpiderHost}: not implemented"

222233

223234instance MonadTrans (WithWebView x) where

224235 lift = WithWebView . lift

@@ -248,11 +259,25 @@ attachWidget :: forall e x a. (IsHTMLElement e) => e -> WebViewSingleton x -> Wi

248259attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment

249260 Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement

250261 frames <- liftIO newChan

251− rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv :: GuiEnv Spider (WithWebView x SpiderHost) x

262+ followupEvents <- liftIO $ newIORef []

263+ rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv followupEvents :: GuiEnv Spider (WithWebView x SpiderHost) x

252264 runWithActions dm = do

253265 voidActionNeeded <- fireEventsAndRead dm $ do

254266 sequence =<< readEvent voidActionHandle

255− runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv

267+ case voidActionNeeded of

268+ Nothing -> return ()

269+ Just va -> do

270+ runHostFrame $ runGui va guiEnv

271+ doFollowup

272+ doFollowup = do

273+ fe <- liftIO $ atomicModifyIORef followupEvents $ \x -> ([], x)

274+ fe' <- forM fe $ \(EventTriggerRef r :=> a) -> do

275+ mt <- readRef r

276+ case mt of

277+ Nothing -> return Nothing

278+ Just t -> return $ Just (t :=> a)

279+ let fe'' = catMaybes fe'

280+ when (not $ null fe'') $ runWithActions fe''

256281 Just df <- liftIO $ documentCreateDocumentFragment doc

257282 (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do

258283 (r, postBuild, va) <- runWidget df w

@@ -262,6 +287,7 @@ attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ do --TO

262287 _ <- liftIO $ nodeAppendChild rootElement $ Just df

263288 voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary

264289 --postGUISync seems to leak memory on GHC (unknown on GHCJS)

290+ doFollowup -- This must go after voidActionHandle is subscribed; otherwise, a loop results

265291 _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe

266292 return result

267293

src/Reflex/Dom/Widget/Basic.hs+7−7

@@ -120,7 +120,7 @@ dyn child = do

120120 let build c = do

121121 Just df <- liftIO $ documentCreateDocumentFragment doc

122122 (result, postBuild, voidActions) <- runWidget df c

123− runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

123+ scheduleFollowup newChildBuiltTriggerRef (result, voidActions)

124124 postBuild

125125 Just p <- liftIO $ nodeGetParentNode endPlaceholder

126126 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

@@ -147,7 +147,7 @@ widgetHold child0 newChild = do

147147 let build c = do

148148 Just df <- liftIO $ documentCreateDocumentFragment doc

149149 (result, postBuild, voidActions) <- runWidget df c

150− runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

150+ scheduleFollowup newChildBuiltTriggerRef (result, voidActions)

151151 postBuild

152152 mp <- liftIO $ nodeGetParentNode endPlaceholder

153153 case mp of

@@ -182,7 +182,7 @@ listWithKey vals mkChild = do

182182 initialState <- iforM curVals $ \k v -> do

183183 (result, postBuild, voidAction) <- buildChild df k v

184184 return ((result, voidAction), postBuild)

185− runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

185+ scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

186186 sequence_ $ fmap snd initialState

187187 Just p <- liftIO $ nodeGetParentNode endPlaceholder

188188 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

@@ -207,7 +207,7 @@ listWithKey vals mkChild = do

207207 return $ Just s

208208 These state _ -> do

209209 return $ Just state

210− runFrameWithTriggerRef newChildrenTriggerRef newState

210+ scheduleFollowup newChildrenTriggerRef newState

211211 postBuild

212212 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren

213213

@@ -262,7 +262,7 @@ listWithKey' initialVals valsChanged mkChild = do

262262 return $ Just s

263263 This state -> do -- No change

264264 return $ Just state

265− runFrameWithTriggerRef newChildrenTriggerRef newState

265+ scheduleFollowup newChildrenTriggerRef newState

266266 postBuild

267267 mapDyn (fmap (fst . fst)) children

268268

@@ -290,7 +290,7 @@ listViewWithKey' vals mkChild = do

290290 initialState <- iforM curVals $ \k v -> do

291291 (result, postBuild, voidAction) <- buildChild df k v

292292 return ((result, voidAction), postBuild)

293− runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

293+ scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame

294294 sequence_ $ fmap snd initialState

295295 Just p <- liftIO $ nodeGetParentNode endPlaceholder

296296 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

@@ -315,7 +315,7 @@ listViewWithKey' vals mkChild = do

315315 return $ Just s

316316 These state _ -> do

317317 return $ Just state

318− runFrameWithTriggerRef newChildrenTriggerRef newState

318+ scheduleFollowup newChildrenTriggerRef newState

319319 postBuild

320320 return $ fmap (fmap (fst . fst)) children

321321