mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
Add some more stuff to test/prebuild.hs
This commit is contained in:
parent
dfbba87c3e
commit
fd7c758220
@ -1,6 +1,9 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans
|
||||
import Reflex.Dom
|
||||
@ -8,8 +11,13 @@ import qualified Data.Text as T
|
||||
import Control.Concurrent
|
||||
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Functor.Misc
|
||||
import Data.Monoid
|
||||
import Data.Word
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Dependent.Map as DMap
|
||||
import Data.Dependent.Sum
|
||||
import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
|
||||
|
||||
main :: IO ()
|
||||
main = mainWidget w
|
||||
@ -17,7 +25,7 @@ main = mainWidget w
|
||||
w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()
|
||||
w = do
|
||||
let slow :: forall m'. MonadWidget t m' => m' ()
|
||||
{-
|
||||
{-
|
||||
performEventChain = do
|
||||
postBuild <- delay 0 =<< getPostBuild
|
||||
rec let maxN = 10000
|
||||
@ -26,8 +34,8 @@ w = do
|
||||
pausedUntil $ ffilter (==maxN) n'
|
||||
_ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
|
||||
return ()
|
||||
-}
|
||||
{-
|
||||
-}
|
||||
{- Many dyns
|
||||
slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
|
||||
where maxDepth = 6 :: Int
|
||||
go 0 = blank
|
||||
@ -38,19 +46,21 @@ w = do
|
||||
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
|
||||
-}
|
||||
{-
|
||||
-}
|
||||
{- Many elDynAttrs
|
||||
slow = do
|
||||
let size = 64
|
||||
replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do
|
||||
replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank
|
||||
-}
|
||||
{- Many dynTexts
|
||||
slow = el "table" $ do
|
||||
let size = 64
|
||||
replicateM_ size $ el "tr" $ do
|
||||
replicateM_ size $ el "td" $ do
|
||||
dynText $ pure "."
|
||||
{-
|
||||
-}
|
||||
{- Many simultaneous performEvents
|
||||
slow = do
|
||||
postBuild <- getPostBuild
|
||||
replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
|
||||
@ -58,29 +68,37 @@ w = do
|
||||
_ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
|
||||
return ()
|
||||
-}
|
||||
el "h1" $ text "Bad"
|
||||
{-
|
||||
slow = do
|
||||
postBuild <- getPostBuild
|
||||
postBuild' <- performEvent . (return () <$) =<< performEvent . (return () <$) =<< getPostBuild
|
||||
let f x = Map.fromList [(n, x) | n <- [1 :: Int .. 4096]]
|
||||
listHoldWithKey (f False) (f (Just True) <$ postBuild') $ \k -> \case
|
||||
False -> do
|
||||
text "X "
|
||||
notReadyUntil =<< getPostBuild
|
||||
True -> do
|
||||
text ". "
|
||||
return ()
|
||||
-}
|
||||
slow = do
|
||||
let f :: forall a. EitherTag () () a -> Const2 () () a -> m' (Const2 () () a)
|
||||
f _ (Const2 ()) = do
|
||||
notReadyUntil =<< delay 0.5 =<< getPostBuild
|
||||
text "Done"
|
||||
return $ Const2 ()
|
||||
postBuild <- getPostBuild
|
||||
traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild
|
||||
return ()
|
||||
el "div" $ do
|
||||
draw <- button "Draw"
|
||||
widgetHold blank $ ffor draw $ \_ -> do
|
||||
postBuild <- getPostBuild
|
||||
widgetHold (text "Loading...") $ slow <$ postBuild
|
||||
return ()
|
||||
el "h1" $ text "Bad - with EventWriterT"
|
||||
el "div" $ do
|
||||
draw <- button "Draw"
|
||||
widgetHold blank $ ffor draw $ \_ -> do
|
||||
(_, w :: Dynamic t ()) <- runDynamicWriterT slow
|
||||
return ()
|
||||
el "h1" $ text "Good"
|
||||
el "div" $ do
|
||||
draw <- button "Draw"
|
||||
widgetHold blank $ ffor draw $ \_ -> do
|
||||
(df0, _) <- buildDomFragment $ text "Loading..."
|
||||
(df', (doneBuilding, _)) <- buildDomFragment $ do
|
||||
slow
|
||||
postBuild <- getPostBuild
|
||||
return (postBuild, ())
|
||||
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 ()
|
||||
|
||||
instance {-# INCOHERENT #-} (Show (f a), Show (f b)) => ShowTag (EitherTag a b) f where
|
||||
showTagToShow e _ = case e of
|
||||
LeftTag -> id
|
||||
RightTag -> id
|
||||
|
Loading…
Reference in New Issue
Block a user