1e930c2 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Add notReady and notReadyUntil

1e930c2Ryan Trinkle10 years ago

src/Reflex/Dom/Builder/Class.hs+14

compare with develop

unifiedsplit

@@ -141,6 +141,20 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), MonadAdjust t m) => DomB

141 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

142 }

143 {-# INLINABLE wrapRawElement #-}

144+ notReadyUntil :: Event t a -> m ()

145+ default notReadyUntil :: ( MonadTrans f

146+ , m ~ f m'

147+ , DomBuilder t m'

148+ )

149+ => Event t a -> m ()

150+ notReadyUntil = lift . notReadyUntil

151+ notReady :: m ()

152+ default notReady :: ( MonadTrans f

153+ , m ~ f m'

154+ , DomBuilder t m'

155+ )

156+ => m ()

157+ notReady = lift notReady

144

158

145class DomBuilder t m => MountableDomBuilder t m where

159class DomBuilder t m => MountableDomBuilder t m where

146 type DomFragment m :: *

160 type DomFragment m :: *

src/Reflex/Dom/Builder/Immediate.hs+62−16

@@ -83,6 +83,8 @@ data ImmediateDomBuilderEnv t

83 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

84 , _immediateDomBuilderEnv_parent :: Node

85 , _immediateDomBuilderEnv_events :: Chan [DSum (TriggerRef t) TriggerInvocation]

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

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

86 }

88 }

88newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

90newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

@@ -198,9 +200,9 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR

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

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

199wrap e cfg = do

201wrap e cfg = do

200 events <- askEvents

202 events <- askEvents

201− mapM_ (performEvent_ . fmap (imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

203+ forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> performEvent $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

202 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

204 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

203− Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv)) (_rawElementConfig_modifyAttributes cfg)

205+ Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

204 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

206 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

205 triggerRef <- newIORef Nothing

207 triggerRef <- newIORef Nothing

206 _ <- elementOnEventName en e $ do

208 _ <- elementOnEventName en e $ do

@@ -230,23 +232,24 @@ wrap e cfg = do

230 --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

232 --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

231 ref <- newIORef $ Just t

233 ref <- newIORef $ Just t

232 writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())]

234 writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())]

233− return $ Element es e

235+ return $ Element

236+ { _element_events = es

237+ , _element_raw = e

238+ }

234

239

235{-# INLINABLE makeElement #-}

240{-# INLINABLE makeElement #-}

236makeElement :: 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)

241makeElement :: 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)

237makeElement elementTag cfg child = do

242makeElement elementTag cfg child = do

238− doc <- askDocument

243+ env <- ImmediateDomBuilderT ask

239− events <- askEvents

244+ let doc = _immediateDomBuilderEnv_document env

240 Just e <- ImmediateDomBuilderT $ fmap DOM.castToElement <$> case cfg ^. namespace of

245 Just e <- ImmediateDomBuilderT $ fmap DOM.castToElement <$> case cfg ^. namespace of

241 Nothing -> createElement doc (Just elementTag)

246 Nothing -> createElement doc (Just elementTag)

242 Just ens -> createElementNS doc (Just ens) (Just elementTag)

247 Just ens -> createElementNS doc (Just ens) (Just elementTag)

243 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

248 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

244 Nothing -> setAttribute e n v

249 Nothing -> setAttribute e n v

245 Just ans -> setAttributeNS e (Just ans) n v

250 Just ans -> setAttributeNS e (Just ans) n v

246− result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv

251+ result <- lift $ runImmediateDomBuilderT child $ env

247 { _immediateDomBuilderEnv_parent = toNode e

252 { _immediateDomBuilderEnv_parent = toNode e

248− , _immediateDomBuilderEnv_document = doc

249− , _immediateDomBuilderEnv_events = events

250 }

253 }

251 append e

254 append e

252 wrapped <- wrap e $ extractRawElementConfig cfg

255 wrapped <- wrap e $ extractRawElementConfig cfg

@@ -414,6 +417,21 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

414 return (wrapped, result)

417 return (wrapped, result)

415 placeRawElement = append

418 placeRawElement = append

416 wrapRawElement = wrap

419 wrapRawElement = wrap

420+ notReadyUntil e = do

421+ eOnce <- headE e

422+ env <- ImmediateDomBuilderT ask

423+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

424+ liftIO $ modifyIORef' unreadyChildren succ

425+ let ready = liftIO $ do

426+ old <- readIORef unreadyChildren

427+ let new = pred old

428+ writeIORef unreadyChildren $! new

429+ when (new == 0) $ _immediateDomBuilderEnv_commitAction env

430+ performEvent_ $ ready <$ eOnce

431+ notReady = do

432+ env <- ImmediateDomBuilderT ask

433+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

434+ liftIO $ modifyIORef' unreadyChildren succ

417

435

418data FragmentState

436data FragmentState

419 = FragmentState_Unmounted

437 = FragmentState_Unmounted

@@ -474,19 +492,48 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m,

474 runWithReplace a0 a' = do

492 runWithReplace a0 a' = do

475 initialEnv <- ImmediateDomBuilderT ask

493 initialEnv <- ImmediateDomBuilderT ask

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

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

495+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

496+ haveEverBeenReady <- liftIO $ newIORef False

497+ let myCommitAction = liftIO $ do --TODO: When we change out a child, we need to cancel it's ability to declare us ready

498+ readIORef haveEverBeenReady >>= \case

499+ True -> return ()

500+ False -> do

501+ writeIORef haveEverBeenReady True

502+ old <- readIORef parentUnreadyChildren

503+ let new = pred old

504+ writeIORef parentUnreadyChildren $! new

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

477 -- We draw 'after' in this roundabout way to avoid using MonadFix

506 -- We draw 'after' in this roundabout way to avoid using MonadFix

478 Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)

507 Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)

479 let drawInitialChild = do

508 let drawInitialChild = do

509+ unreadyChildren <- liftIO $ newIORef 0

510+ let f = do

480− result <- a0

511+ result <- a0

481− append after

512+ append after

513+ return result

514+ result <- runImmediateDomBuilderT f $ initialEnv

515+ { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

516+ , _immediateDomBuilderEnv_commitAction = myCommitAction

517+ }

518+ liftIO $ readIORef unreadyChildren >>= \case

519+ 0 -> writeIORef haveEverBeenReady True

520+ _ -> modifyIORef' parentUnreadyChildren succ

482 return result

521 return result

483− (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do

522+ (result0, result') <- lift $ runWithReplace drawInitialChild $ ffor a' $ \child -> do

484 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

523 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

524+ unreadyChildren <- liftIO $ newIORef 0

525+ let commitAction = do

526+ deleteBetweenExclusive before after

527+ insertBefore df after

528+ myCommitAction

485 result <- runImmediateDomBuilderT child $ initialEnv

529 result <- runImmediateDomBuilderT child $ initialEnv

486 { _immediateDomBuilderEnv_parent = toNode df

530 { _immediateDomBuilderEnv_parent = toNode df

531+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

532+ , _immediateDomBuilderEnv_commitAction = commitAction

487 }

533 }

488− deleteBetweenExclusive before after

534+ liftIO $ readIORef unreadyChildren >>= \case

489− insertBefore df after

535+ 0 -> commitAction

536+ _ -> return () -- Whoever decrements it to 0 will handle it

490 return result

537 return result

491 return (result0, result')

538 return (result0, result')

492 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

539 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

@@ -567,14 +614,13 @@ mkHasFocus e = do

567{-# INLINABLE insertImmediateAbove #-}

614{-# INLINABLE insertImmediateAbove #-}

568insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

615insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

569insertImmediateAbove n toInsertAbove = do

616insertImmediateAbove n toInsertAbove = do

570− events <- askEvents

617+ env <- ImmediateDomBuilderT ask

571 lift $ performEvent $ ffor toInsertAbove $ \new -> do

618 lift $ performEvent $ ffor toInsertAbove $ \new -> do

572 Just doc <- getOwnerDocument n

619 Just doc <- getOwnerDocument n

573 Just df <- createDocumentFragment doc

620 Just df <- createDocumentFragment doc

574− result <- runImmediateDomBuilderT new $ ImmediateDomBuilderEnv

621+ result <- runImmediateDomBuilderT new $ env

575 { _immediateDomBuilderEnv_parent = toNode df

622 { _immediateDomBuilderEnv_parent = toNode df

576 , _immediateDomBuilderEnv_document = doc

623 , _immediateDomBuilderEnv_document = doc

577− , _immediateDomBuilderEnv_events = events

578 }

624 }

579 df `insertBefore` n

625 df `insertBefore` n

580 return result

626 return result

src/Reflex/Dom/Builder/Static.hs+7−1

@@ -204,7 +204,11 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

204 let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]

205 let close = constant $ byteString $ "</" <> tagBS <> ">"

206 modify $ (:) $ mconcat [open, innerHtml, close]

207− return (Element es (), result)

207+ let e = Element

208+ { _element_events = es

209+ , _element_raw = ()

210+ }

211+ return (e, result)

208 {-# INLINABLE inputElement #-}

212 {-# INLINABLE inputElement #-}

209 inputElement cfg = do

213 inputElement cfg = do

210 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

214 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

@@ -250,6 +254,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

250 return (wrapped, result)

254 return (wrapped, result)

251 placeRawElement () = return ()

255 placeRawElement () = return ()

252 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

256 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

257+ notReadyUntil _ = return () --TODO: Do we need to support this somehow?

258+ notReady = return () --TODO: Do we need to support this somehow?

253

259

254--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

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

261type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))

src/Reflex/Dom/Internal.hs+6

@@ -88,10 +88,13 @@ mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingletonMono w

88 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

89 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c

90 go w df = do

91+ unreadyChildren <- liftIO $ newIORef 0

91 let builderEnv = ImmediateDomBuilderEnv

92 let builderEnv = ImmediateDomBuilderEnv

92 { _immediateDomBuilderEnv_document = toDocument doc

93 { _immediateDomBuilderEnv_document = toDocument doc

93 , _immediateDomBuilderEnv_parent = toNode df

94 , _immediateDomBuilderEnv_parent = toNode df

94 , _immediateDomBuilderEnv_events = events

95 , _immediateDomBuilderEnv_events = events

96+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

97+ , _immediateDomBuilderEnv_commitAction = return () --TODO

95 }

98 }

96 runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

99 runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

97 rec b <- go (headWidget a) headFragment

100 rec b <- go (headWidget a) headFragment

@@ -114,10 +117,13 @@ attachWidget' rootElement wv w = do

114 Just df <- createDocumentFragment doc

117 Just df <- createDocumentFragment doc

115 ((a, events), fc) <- attachWidget'' $ \events -> do

118 ((a, events), fc) <- attachWidget'' $ \events -> do

116 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

119 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

120+ unreadyChildren <- liftIO $ newIORef 0

117 let builderEnv = ImmediateDomBuilderEnv

121 let builderEnv = ImmediateDomBuilderEnv

118 { _immediateDomBuilderEnv_document = toDocument doc

122 { _immediateDomBuilderEnv_document = toDocument doc

119 , _immediateDomBuilderEnv_parent = toNode df

123 , _immediateDomBuilderEnv_parent = toNode df

120 , _immediateDomBuilderEnv_events = events

124 , _immediateDomBuilderEnv_events = events

125+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

126+ , _immediateDomBuilderEnv_commitAction = return () --TODO

121 }

127 }

122 a <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

128 a <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

123 return ((a, events), postBuildTriggerRef)

129 return ((a, events), postBuildTriggerRef)

src/Reflex/Dom/Widget/Basic.hs+9−3

@@ -85,6 +85,7 @@ import Reflex.Dom.Builder.Class

85import Reflex.Dom.Class

86import Reflex.Dom.Internal.Foreign ()

87import Reflex.Dynamic

88+import Reflex.PerformEvent.Class

88import Reflex.PostBuild.Class

89import Reflex.PostBuild.Class

90import Control.Arrow

91import Control.Arrow

@@ -145,6 +146,7 @@ dynText t = do

145 [ updated t

146 [ updated t

146 , tag (current t) postBuild

147 , tag (current t) postBuild

147 ]

148 ]

149+ notReadyUntil postBuild

148

150

149display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

151display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

150display = dynText . fmap (T.pack . show)

152display = dynText . fmap (T.pack . show)

@@ -162,7 +164,8 @@ dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

162dyn child = do

164dyn child = do

163 postBuild <- getPostBuild

165 postBuild <- getPostBuild

164 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

166 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

165− snd <$> widgetHoldInternal (return ()) newChild

167+ result <- snd <$> widgetHoldInternal notReady newChild

168+ return result

166

169

167-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

170-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

168-- The returned Dynamic of widget results occurs when the Event does.

171-- The returned Dynamic of widget results occurs when the Event does.

@@ -342,8 +345,11 @@ elDynAttrNS' mns elementTag attrs child = do

342 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

345 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

343 let cfg = def

346 let cfg = def

344 & elementConfig_namespace .~ mns

347 & elementConfig_namespace .~ mns

345− & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

348+ & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs

346− element elementTag cfg child

349+ result <- element elementTag cfg child

350+ postBuild <- getPostBuild

351+ notReadyUntil postBuild

352+ return result

347

353

348dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))

354dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))

349dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

355dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

test/prebuild.hs+42−27

@@ -11,30 +11,12 @@ import Control.Monad.State.Strict

11import Data.Monoid

12import Data.Word

14−type Paused t = DynamicWriterT t All

15−

16−runPaused :: (Reflex t, MonadFix m, MonadHold t m) => Paused t m a -> m (Event t (), a)

17−runPaused a = do

18− (result, runnable) <- runDynamicWriterT a

19− let done = void $ ffilter getAll $ updated $ uniqDyn runnable

20− return (done, result)

21−

22−--TODO: Perhaps we could use guaranteed-single-shot events here

23−pausedUntil :: (Reflex t, MonadFix m, MonadHold t m) => Event t a -> Paused t m ()

24−pausedUntil e = do

25− tellDyn =<< holdDyn (All False) (All True <$ e) --TODO: Disconnect after one firing

26−

27−dyn' :: (DomBuilder t m, PostBuild t m, m ~ Paused t m', MonadFix m', MonadHold t m') => Dynamic t (m a) -> m (Event t a)

28−dyn' child = do

29− postBuild <- getPostBuild

30− let newChild = leftmost [updated child, tagCheap (current child) postBuild]

31− newChildDone <- snd <$> runWithReplace (return ()) newChild

32− pausedUntil newChildDone

33− return newChildDone

34−

35main :: IO ()

14main :: IO ()

36−main = mainWidget $ do

15+main = mainWidget w

37− let slow = dynTree

16+

17+w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()

18+w = do

19+ let slow :: forall m'. MonadWidget t m' => m' ()

38 {-

20 {-

39 performEventChain = do

21 performEventChain = do

40 postBuild <- delay 0 =<< getPostBuild

22 postBuild <- delay 0 =<< getPostBuild

@@ -45,26 +27,59 @@ main = mainWidget $ do

45 _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n

27 _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n

46 return ()

28 return ()

47 -}

29 -}

30+ {-

48− dynTree = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth

31+ slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth

49 where maxDepth = 6 :: Int

32 where maxDepth = 6 :: Int

50 go 0 = blank

33 go 0 = blank

51− go n = void $ dyn' $ pure $ do

34+ go n = void $ dyn $ pure $ do

52 let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"

35 let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"

53 s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor

36 s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor

54 elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n

37 elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n

55 elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n

38 elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n

56 elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n

39 elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n

57 elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n

40 elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n

41+ -}

42+ {-

43+ slow = do

44+ let size = 64

45+ replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do

46+ replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank

47+ -}

48+ slow = el "table" $ do

49+ let size = 64

50+ replicateM_ size $ el "tr" $ do

51+ replicateM_ size $ el "td" $ do

52+ dynText $ pure "."

53+ {-

54+ slow = do

55+ postBuild <- getPostBuild

56+ replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild

57+ done <- performEvent $ return () <$ postBuild

58+ _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done

59+ return ()

60+ -}

58 el "h1" $ text "Bad"

61 el "h1" $ text "Bad"

59 el "div" $ do

62 el "div" $ do

60 draw <- button "Draw"

63 draw <- button "Draw"

61− widgetHold blank $ ffor draw $ \_ -> void $ runPaused slow

64+ widgetHold blank $ ffor draw $ \_ -> do

65+ postBuild <- getPostBuild

66+ widgetHold (text "Loading...") $ slow <$ postBuild

67+ return ()

68+ el "h1" $ text "Bad - with EventWriterT"

69+ el "div" $ do

70+ draw <- button "Draw"

71+ widgetHold blank $ ffor draw $ \_ -> do

72+ (_, w :: Dynamic t ()) <- runDynamicWriterT slow

73+ return ()

62 el "h1" $ text "Good"

74 el "h1" $ text "Good"

63 el "div" $ do

75 el "div" $ do

64 draw <- button "Draw"

76 draw <- button "Draw"

65 widgetHold blank $ ffor draw $ \_ -> do

77 widgetHold blank $ ffor draw $ \_ -> do

66 (df0, _) <- buildDomFragment $ text "Loading..."

78 (df0, _) <- buildDomFragment $ text "Loading..."

67− (df', (doneBuilding, _)) <- buildDomFragment $ runPaused slow

79+ (df', (doneBuilding, _)) <- buildDomFragment $ do

80+ slow

81+ postBuild <- getPostBuild

82+ return (postBuild, ())

68 mountDomFragment df0 $ df' <$ doneBuilding

83 mountDomFragment df0 $ df' <$ doneBuilding

69 postBuild <- getPostBuild

84 postBuild <- getPostBuild

70 performEvent_ $ liftIO (threadDelay 0) <$ postBuild -- This is necessary so that ghcjs will release the thread back to the DOM so that we see the loading indicator immediately; we could instead adjust the parameters to GHCJS so that the thread quantum is smaller.

85 performEvent_ $ liftIO (threadDelay 0) <$ postBuild -- This is necessary so that ghcjs will release the thread back to the DOM so that we see the loading indicator immediately; we could instead adjust the parameters to GHCJS so that the thread quantum is smaller.