05fe043 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add a test for using fragments as a loading indicator

commit05fe04354e88737a893dfd66b9f295f8a1da840d authorRyan Trinkle <ryan.trinkle@gmail.com> dateTue 7 Mar 2017, 01:10 (10 years ago) parent6fb8761

4 files changed+144−56

compare with develop

unifiedsplit

src/Foreign/JavaScript/TH.hs+4−1 src/Reflex/Dom/Builder/Class.hs+10 src/Reflex/Dom/Builder/Immediate.hs+58−55 test/prebuild.hs+72

src/Foreign/JavaScript/TH.hs+4−1

@@ -167,12 +167,15 @@ instance MonadTransControl (WithWebView x) where

167167 restoreT = defaultRestoreT WithWebView

168168

169169instance PerformEvent t m => PerformEvent t (WithWebView x m) where

170− type Performable (WithWebView x m) = WithWebView x (Performable m)

170+ type Performable (WithWebView x m) = WithWebView x (Performable m) --TODO: Can we eliminate this wrapper?

171171 {-# INLINABLE performEvent_ #-}

172172 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

173173 {-# INLINABLE performEvent #-}

174174 performEvent e = liftWith $ \run -> performEvent $ fmap run e

175175

176+instance ExhaustiblePerformEvent t m => ExhaustiblePerformEvent t (WithWebView x m) where

177+ withPerformEventExhausted a = liftWith $ \run -> withPerformEventExhausted $ run a

178+

176179runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a

177180runWithWebView = runReaderT . unWithWebView

178181

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

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

142142 }

143143 {-# INLINABLE wrapRawElement #-}

144144

145+class DomBuilder t m => MountableDomBuilder t m where

146+ type DomFragment m :: *

147+ buildDomFragment :: m a -> m (DomFragment m, a)

148+ mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m ()

149+

145150type Namespace = Text

146151

147152data TextNodeConfig t

@@ -428,6 +433,11 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui

428433 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

429434 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg

430435

436+instance (MountableDomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => MountableDomBuilder t (PostBuildT t m) where

437+ type DomFragment (PostBuildT t m) = DomFragment m

438+ buildDomFragment = liftThrough buildDomFragment

439+ mountDomFragment f0 f' = lift $ mountDomFragment f0 f'

440+

431441instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where

432442 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m

433443 textNode = liftTextNode

src/Reflex/Dom/Builder/Immediate.hs+58−55

@@ -415,6 +415,61 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

415415 placeRawElement = append

416416 wrapRawElement = wrap

417417

418+data FragmentState

419+ = FragmentState_Unmounted

420+ | FragmentState_Mounted (DOM.Text, DOM.Text)

421+

422+data ImmediateDomFragment = ImmediateDomFragment

423+ { _immediateDomFragment_document :: DOM.DocumentFragment

424+ , _immediateDomFragment_state :: IORef FragmentState

425+ }

426+

427+extractFragment :: MonadIO m => ImmediateDomFragment -> m ()

428+extractFragment fragment = do

429+ state <- liftIO $ readIORef $ _immediateDomFragment_state fragment

430+ case state of

431+ FragmentState_Unmounted -> return ()

432+ FragmentState_Mounted (before, after) -> do

433+ extractBetweenExclusive (_immediateDomFragment_document fragment) before after

434+ liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted

435+

436+-- | s and e must both be children of the same node and s must precede e; all

437+-- nodes between s and e will be moved into the given DocumentFragment, but s

438+-- and e will not be moved

439+extractBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()

440+extractBetweenExclusive df s e = go

441+ where

442+ go = do

443+ Just x <- getNextSibling s -- This can't be Nothing because we should hit 'e' first

444+ when (toNode e /= toNode x) $ do

445+ _ <- appendChild df $ Just x

446+ go

447+

448+instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where

449+ type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment

450+ buildDomFragment w = do

451+ initialEnv <- ImmediateDomBuilderT ask

452+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

453+ result <- lift $ runImmediateDomBuilderT w $ initialEnv

454+ { _immediateDomBuilderEnv_parent = toNode df

455+ }

456+ state <- liftIO $ newIORef FragmentState_Unmounted

457+ return (ImmediateDomFragment df state, result)

458+ mountDomFragment fragment setFragment = do

459+ parent <- askParent

460+ extractFragment fragment

461+ before <- textNodeInternal ("" :: Text)

462+ _ <- appendChild parent $ Just $ _immediateDomFragment_document fragment

463+ after <- textNodeInternal ("" :: Text)

464+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment

465+ performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do

466+ extractFragment previousFragment

467+ extractFragment childFragment

468+ insertBefore (_immediateDomFragment_document childFragment) after

469+ liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

470+ liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

471+

472+

418473instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

419474 runWithReplace a0 a' = do

420475 initialEnv <- ImmediateDomBuilderT ask

@@ -538,6 +593,9 @@ instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

538593 {-# INLINABLE performEvent #-}

539594 performEvent e = lift $ performEvent e

540595

596+instance ExhaustiblePerformEvent t m => ExhaustiblePerformEvent t (ImmediateDomBuilderT t m) where

597+ withPerformEventExhausted a = liftWith $ \run -> withPerformEventExhausted $ run a

598+

541599instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where

542600 {-# INLINABLE getPostBuild #-}

543601 getPostBuild = lift getPostBuild

@@ -1019,58 +1077,3 @@ wrapWindow wv _ = do

10191077 }

10201078

10211079makeLenses ''GhcjsEventSpec

1022−

1023−data FragmentState

1024− = FragmentState_Created

1025− | FragmentState_Mounted (DOM.Text, DOM.Text)

1026−

1027−data DomFragment = DomFragment

1028− { _domFragment_document :: DOM.DocumentFragment

1029− , _domFragment_state :: IORef FragmentState

1030− }

1031−

1032−domFragment :: MonadIO m => ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m (DomFragment, a)

1033−domFragment w = do

1034− initialEnv <- ImmediateDomBuilderT ask

1035− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

1036− result <- lift $ runImmediateDomBuilderT w $ initialEnv

1037− { _immediateDomBuilderEnv_parent = toNode df

1038− }

1039− state <- liftIO $ newIORef FragmentState_Created

1040− return (DomFragment df state, result)

1041−

1042−mountDomFragment :: (PerformEvent t m, MonadIO m, MonadIO (Performable m), MonadFix m, MonadHold t m) => DomFragment -> Event t DomFragment -> ImmediateDomBuilderT t m ()

1043−mountDomFragment fragment setFragment = do

1044− parent <- askParent

1045− extractFragment fragment

1046− before <- textNodeInternal ("" :: Text)

1047− _ <- appendChild parent $ Just $ _domFragment_document fragment

1048− after <- textNodeInternal ("" :: Text)

1049− xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment

1050− performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do

1051− extractFragment previousFragment

1052− extractFragment childFragment

1053− insertBefore (_domFragment_document childFragment) after

1054− liftIO $ writeIORef (_domFragment_state childFragment) $ FragmentState_Mounted (before, after)

1055− liftIO $ writeIORef (_domFragment_state fragment) $ FragmentState_Mounted (before, after)

1056−

1057−extractFragment :: MonadIO m => DomFragment -> m ()

1058−extractFragment fragment = do

1059− state <- liftIO $ readIORef $ _domFragment_state fragment

1060− case state of

1061− FragmentState_Created -> return ()

1062− FragmentState_Mounted (before, after) -> do

1063− extractBetweenExclusive (_domFragment_document fragment) before after

1064− liftIO $ writeIORef (_domFragment_state fragment) FragmentState_Created

1065−

1066−-- | s and e must both be children of the same node and s must precede e; all

1067−-- nodes between s and e will be moved into the given DocumentFragment, but s

1068−-- and e will not be moved

1069−extractBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()

1070−extractBetweenExclusive df s e = go

1071− where

1072− go = do

1073− Just x <- getNextSibling s -- This can't be Nothing because we should hit 'e' first

1074− when (toNode e /= toNode x) $ do

1075− _ <- appendChild df $ Just x

1076− go

test/prebuild.hsnew file+72

@@ -0,0 +1,72 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE RecursiveDo #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TypeFamilies #-}

5+import Control.Monad

6+import Control.Monad.Trans

7+import Reflex.Dom

8+import qualified Data.Text as T

9+import Control.Concurrent

10+

11+import Control.Monad.State.Strict

12+import Data.Monoid

13+import Data.Word

14+

15+type Paused t = DynamicWriterT t All

16+

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

18+runPaused a = do

19+ (result, runnable) <- runDynamicWriterT a

20+ let done = void $ ffilter getAll $ updated $ uniqDyn runnable

21+ return (done, result)

22+

23+--TODO: Perhaps we could use guaranteed-single-shot events here

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

25+pausedUntil e = do

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

27+

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

29+dyn' child = do

30+ postBuild <- getPostBuild

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

32+ newChildDone <- snd <$> runWithReplace (return ()) newChild

33+ pausedUntil newChildDone

34+ return newChildDone

35+

36+main :: IO ()

37+main = mainWidget $ do

38+ let slow = dynTree

39+ {-

40+ performEventChain = do

41+ postBuild <- delay 0 =<< getPostBuild

42+ rec let maxN = 10000

43+ n = leftmost [0 <$ postBuild, ffilter (<=maxN) $ succ <$> n']

44+ n' <- performEvent $ return <$> n

45+ pausedUntil $ ffilter (==maxN) n'

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

47+ return ()

48+ -}

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

50+ where maxDepth = 6 :: Int

51+ go 0 = blank

52+ go n = void $ dyn' $ pure $ do

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

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

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

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

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

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

59+ el "h1" $ text "Bad"

60+ el "div" $ do

61+ draw <- button "Draw"

62+ widgetHold blank $ ffor draw $ \_ -> void $ runPaused slow

63+ el "h1" $ text "Good"

64+ el "div" $ do

65+ draw <- button "Draw"

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

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

68+ (df', (doneBuilding, _)) <- buildDomFragment $ runPaused slow

69+ mountDomFragment df0 $ df' <$ doneBuilding

70+ postBuild <- getPostBuild

71+ 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.

72+ return ()