mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
Add a test for using fragments as a loading indicator
This commit is contained in:
Ryan Trinkle
parent
6fb8761a2c
commit
05fe04354e
@ -167,12 +167,15 @@ instance MonadTransControl (WithWebView x) where
|
||||
restoreT = defaultRestoreT WithWebView
|
||||
|
||||
instance PerformEvent t m => PerformEvent t (WithWebView x m) where
|
||||
type Performable (WithWebView x m) = WithWebView x (Performable m)
|
||||
type Performable (WithWebView x m) = WithWebView x (Performable m) --TODO: Can we eliminate this wrapper?
|
||||
{-# INLINABLE performEvent_ #-}
|
||||
performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
|
||||
{-# INLINABLE performEvent #-}
|
||||
performEvent e = liftWith $ \run -> performEvent $ fmap run e
|
||||
|
||||
instance ExhaustiblePerformEvent t m => ExhaustiblePerformEvent t (WithWebView x m) where
|
||||
withPerformEventExhausted a = liftWith $ \run -> withPerformEventExhausted $ run a
|
||||
|
||||
runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
|
||||
runWithWebView = runReaderT . unWithWebView
|
||||
|
||||
|
||||
@ -142,6 +142,11 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), MonadAdjust t m) => DomB
|
||||
}
|
||||
{-# INLINABLE wrapRawElement #-}
|
||||
|
||||
class DomBuilder t m => MountableDomBuilder t m where
|
||||
type DomFragment m :: *
|
||||
buildDomFragment :: m a -> m (DomFragment m, a)
|
||||
mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m ()
|
||||
|
||||
type Namespace = Text
|
||||
|
||||
data TextNodeConfig t
|
||||
@ -428,6 +433,11 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui
|
||||
type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m
|
||||
wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg
|
||||
|
||||
instance (MountableDomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => MountableDomBuilder t (PostBuildT t m) where
|
||||
type DomFragment (PostBuildT t m) = DomFragment m
|
||||
buildDomFragment = liftThrough buildDomFragment
|
||||
mountDomFragment f0 f' = lift $ mountDomFragment f0 f'
|
||||
|
||||
instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
|
||||
type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
|
||||
textNode = liftTextNode
|
||||
|
||||
@ -415,6 +415,61 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
|
||||
placeRawElement = append
|
||||
wrapRawElement = wrap
|
||||
|
||||
data FragmentState
|
||||
= FragmentState_Unmounted
|
||||
| FragmentState_Mounted (DOM.Text, DOM.Text)
|
||||
|
||||
data ImmediateDomFragment = ImmediateDomFragment
|
||||
{ _immediateDomFragment_document :: DOM.DocumentFragment
|
||||
, _immediateDomFragment_state :: IORef FragmentState
|
||||
}
|
||||
|
||||
extractFragment :: MonadIO m => ImmediateDomFragment -> m ()
|
||||
extractFragment fragment = do
|
||||
state <- liftIO $ readIORef $ _immediateDomFragment_state fragment
|
||||
case state of
|
||||
FragmentState_Unmounted -> return ()
|
||||
FragmentState_Mounted (before, after) -> do
|
||||
extractBetweenExclusive (_immediateDomFragment_document fragment) before after
|
||||
liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted
|
||||
|
||||
-- | s and e must both be children of the same node and s must precede e; all
|
||||
-- nodes between s and e will be moved into the given DocumentFragment, but s
|
||||
-- and e will not be moved
|
||||
extractBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
|
||||
extractBetweenExclusive df s e = go
|
||||
where
|
||||
go = do
|
||||
Just x <- getNextSibling s -- This can't be Nothing because we should hit 'e' first
|
||||
when (toNode e /= toNode x) $ do
|
||||
_ <- appendChild df $ Just x
|
||||
go
|
||||
|
||||
instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where
|
||||
type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment
|
||||
buildDomFragment w = do
|
||||
initialEnv <- ImmediateDomBuilderT ask
|
||||
Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
|
||||
result <- lift $ runImmediateDomBuilderT w $ initialEnv
|
||||
{ _immediateDomBuilderEnv_parent = toNode df
|
||||
}
|
||||
state <- liftIO $ newIORef FragmentState_Unmounted
|
||||
return (ImmediateDomFragment df state, result)
|
||||
mountDomFragment fragment setFragment = do
|
||||
parent <- askParent
|
||||
extractFragment fragment
|
||||
before <- textNodeInternal ("" :: Text)
|
||||
_ <- appendChild parent $ Just $ _immediateDomFragment_document fragment
|
||||
after <- textNodeInternal ("" :: Text)
|
||||
xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
|
||||
performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
|
||||
extractFragment previousFragment
|
||||
extractFragment childFragment
|
||||
insertBefore (_immediateDomFragment_document childFragment) after
|
||||
liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)
|
||||
liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)
|
||||
|
||||
|
||||
instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
|
||||
runWithReplace a0 a' = do
|
||||
initialEnv <- ImmediateDomBuilderT ask
|
||||
@ -538,6 +593,9 @@ instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
|
||||
{-# INLINABLE performEvent #-}
|
||||
performEvent e = lift $ performEvent e
|
||||
|
||||
instance ExhaustiblePerformEvent t m => ExhaustiblePerformEvent t (ImmediateDomBuilderT t m) where
|
||||
withPerformEventExhausted a = liftWith $ \run -> withPerformEventExhausted $ run a
|
||||
|
||||
instance PostBuild t m => PostBuild t (ImmediateDomBuilderT t m) where
|
||||
{-# INLINABLE getPostBuild #-}
|
||||
getPostBuild = lift getPostBuild
|
||||
@ -1019,58 +1077,3 @@ wrapWindow wv _ = do
|
||||
}
|
||||
|
||||
makeLenses ''GhcjsEventSpec
|
||||
|
||||
data FragmentState
|
||||
= FragmentState_Created
|
||||
| FragmentState_Mounted (DOM.Text, DOM.Text)
|
||||
|
||||
data DomFragment = DomFragment
|
||||
{ _domFragment_document :: DOM.DocumentFragment
|
||||
, _domFragment_state :: IORef FragmentState
|
||||
}
|
||||
|
||||
domFragment :: MonadIO m => ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m (DomFragment, a)
|
||||
domFragment w = do
|
||||
initialEnv <- ImmediateDomBuilderT ask
|
||||
Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
|
||||
result <- lift $ runImmediateDomBuilderT w $ initialEnv
|
||||
{ _immediateDomBuilderEnv_parent = toNode df
|
||||
}
|
||||
state <- liftIO $ newIORef FragmentState_Created
|
||||
return (DomFragment df state, result)
|
||||
|
||||
mountDomFragment :: (PerformEvent t m, MonadIO m, MonadIO (Performable m), MonadFix m, MonadHold t m) => DomFragment -> Event t DomFragment -> ImmediateDomBuilderT t m ()
|
||||
mountDomFragment fragment setFragment = do
|
||||
parent <- askParent
|
||||
extractFragment fragment
|
||||
before <- textNodeInternal ("" :: Text)
|
||||
_ <- appendChild parent $ Just $ _domFragment_document fragment
|
||||
after <- textNodeInternal ("" :: Text)
|
||||
xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment
|
||||
performEvent_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do
|
||||
extractFragment previousFragment
|
||||
extractFragment childFragment
|
||||
insertBefore (_domFragment_document childFragment) after
|
||||
liftIO $ writeIORef (_domFragment_state childFragment) $ FragmentState_Mounted (before, after)
|
||||
liftIO $ writeIORef (_domFragment_state fragment) $ FragmentState_Mounted (before, after)
|
||||
|
||||
extractFragment :: MonadIO m => DomFragment -> m ()
|
||||
extractFragment fragment = do
|
||||
state <- liftIO $ readIORef $ _domFragment_state fragment
|
||||
case state of
|
||||
FragmentState_Created -> return ()
|
||||
FragmentState_Mounted (before, after) -> do
|
||||
extractBetweenExclusive (_domFragment_document fragment) before after
|
||||
liftIO $ writeIORef (_domFragment_state fragment) FragmentState_Created
|
||||
|
||||
-- | s and e must both be children of the same node and s must precede e; all
|
||||
-- nodes between s and e will be moved into the given DocumentFragment, but s
|
||||
-- and e will not be moved
|
||||
extractBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => DOM.DocumentFragment -> start -> end -> m ()
|
||||
extractBetweenExclusive df s e = go
|
||||
where
|
||||
go = do
|
||||
Just x <- getNextSibling s -- This can't be Nothing because we should hit 'e' first
|
||||
when (toNode e /= toNode x) $ do
|
||||
_ <- appendChild df $ Just x
|
||||
go
|
||||
|
||||
72
test/prebuild.hs
Normal file
72
test/prebuild.hs
Normal file
@ -0,0 +1,72 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans
|
||||
import Reflex.Dom
|
||||
import qualified Data.Text as T
|
||||
import Control.Concurrent
|
||||
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Monoid
|
||||
import Data.Word
|
||||
|
||||
type Paused t = DynamicWriterT t All
|
||||
|
||||
runPaused :: (Reflex t, MonadFix m, MonadHold t m) => Paused t m a -> m (Event t (), a)
|
||||
runPaused a = do
|
||||
(result, runnable) <- runDynamicWriterT a
|
||||
let done = void $ ffilter getAll $ updated $ uniqDyn runnable
|
||||
return (done, result)
|
||||
|
||||
--TODO: Perhaps we could use guaranteed-single-shot events here
|
||||
pausedUntil :: (Reflex t, MonadFix m, MonadHold t m) => Event t a -> Paused t m ()
|
||||
pausedUntil e = do
|
||||
tellDyn =<< holdDyn (All False) (All True <$ e) --TODO: Disconnect after one firing
|
||||
|
||||
dyn' :: (DomBuilder t m, PostBuild t m, m ~ Paused t m', MonadFix m', MonadHold t m') => Dynamic t (m a) -> m (Event t a)
|
||||
dyn' child = do
|
||||
postBuild <- getPostBuild
|
||||
let newChild = leftmost [updated child, tagCheap (current child) postBuild]
|
||||
newChildDone <- snd <$> runWithReplace (return ()) newChild
|
||||
pausedUntil newChildDone
|
||||
return newChildDone
|
||||
|
||||
main :: IO ()
|
||||
main = mainWidget $ do
|
||||
let slow = dynTree
|
||||
{-
|
||||
performEventChain = do
|
||||
postBuild <- delay 0 =<< getPostBuild
|
||||
rec let maxN = 10000
|
||||
n = leftmost [0 <$ postBuild, ffilter (<=maxN) $ succ <$> n']
|
||||
n' <- performEvent $ return <$> n
|
||||
pausedUntil $ ffilter (==maxN) n'
|
||||
_ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
|
||||
return ()
|
||||
-}
|
||||
dynTree = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
|
||||
where maxDepth = 6 :: Int
|
||||
go 0 = blank
|
||||
go n = void $ dyn' $ pure $ do
|
||||
let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"
|
||||
s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor
|
||||
elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n
|
||||
elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
|
||||
elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
|
||||
elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
|
||||
el "h1" $ text "Bad"
|
||||
el "div" $ do
|
||||
draw <- button "Draw"
|
||||
widgetHold blank $ ffor draw $ \_ -> void $ runPaused slow
|
||||
el "h1" $ text "Good"
|
||||
el "div" $ do
|
||||
draw <- button "Draw"
|
||||
widgetHold blank $ ffor draw $ \_ -> do
|
||||
(df0, _) <- buildDomFragment $ text "Loading..."
|
||||
(df', (doneBuilding, _)) <- buildDomFragment $ runPaused slow
|
||||
mountDomFragment df0 $ df' <$ doneBuilding
|
||||
postBuild <- getPostBuild
|
||||
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.
|
||||
return ()
|
||||
Loading…
Reference in New Issue
Block a user