git.iko.soy/reflex-dom
on develop help sign in
Add some more stuff to test/prebuild.hs
fd7c758Ryan Trinkle
test/prebuild.hs+43−25
compare with develop
unifiedsplit
@@ -1,6 +1,9 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
4import Control.Monad
7import Control.Monad
5import Control.Monad.Trans
8import Control.Monad.Trans
6import Reflex.Dom
9import Reflex.Dom
@@ -8,8 +11,13 @@ import qualified Data.Text as T
8import Control.Concurrent
11import Control.Concurrent
9
12
10import Control.Monad.State.Strict
13import Control.Monad.State.Strict
14+import Data.Functor.Misc
11import Data.Monoid
15import Data.Monoid
12import Data.Word
16import Data.Word
17+import qualified Data.Map as Map
18+import qualified Data.Dependent.Map as DMap
19+import Data.Dependent.Sum
20+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
13
21
14main :: IO ()
22main :: IO ()
15main = mainWidget w
23main = mainWidget w
@@ -17,7 +25,7 @@ main = mainWidget w
17w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()
25w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()
18w = do
26w = do
19 let slow :: forall m'. MonadWidget t m' => m' ()
27 let slow :: forall m'. MonadWidget t m' => m' ()
20− {-
28+ {-
21 performEventChain = do
29 performEventChain = do
22 postBuild <- delay 0 =<< getPostBuild
30 postBuild <- delay 0 =<< getPostBuild
23 rec let maxN = 10000
31 rec let maxN = 10000
@@ -26,8 +34,8 @@ w = do
26 pausedUntil $ ffilter (==maxN) n'
34 pausedUntil $ ffilter (==maxN) n'
27 _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
35 _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
28 return ()
36 return ()
29− -}
37+ -}
30− {-
38+ {- Many dyns
31 slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
39 slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
32 where maxDepth = 6 :: Int
40 where maxDepth = 6 :: Int
33 go 0 = blank
41 go 0 = blank
@@ -38,19 +46,21 @@ w = do
38 elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
46 elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
39 elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
47 elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
40 elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
48 elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
41− -}
49+ -}
42− {-
50+ {- Many elDynAttrs
43 slow = do
51 slow = do
44 let size = 64
52 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
53 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
54 replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank
47 -}
55 -}
56+ {- Many dynTexts
48 slow = el "table" $ do
57 slow = el "table" $ do
49 let size = 64
58 let size = 64
50 replicateM_ size $ el "tr" $ do
59 replicateM_ size $ el "tr" $ do
51 replicateM_ size $ el "td" $ do
60 replicateM_ size $ el "td" $ do
52 dynText $ pure "."
61 dynText $ pure "."
53− {-
62+ -}
63+ {- Many simultaneous performEvents
54 slow = do
64 slow = do
55 postBuild <- getPostBuild
65 postBuild <- getPostBuild
56 replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
66 replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
@@ -58,29 +68,37 @@ w = do
58 _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
68 _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
59 return ()
69 return ()
60 -}
70 -}
71+ {-
72+ slow = do
73+ postBuild <- getPostBuild
74+ postBuild' <- performEvent . (return () <$) =<< performEvent . (return () <$) =<< getPostBuild
75+ let f x = Map.fromList [(n, x) | n <- [1 :: Int .. 4096]]
76+ listHoldWithKey (f False) (f (Just True) <$ postBuild') $ \k -> \case
77+ False -> do
78+ text "X "
79+ notReadyUntil =<< getPostBuild
80+ True -> do
81+ text ". "
82+ return ()
83+ -}
84+ slow = do
85+ let f :: forall a. EitherTag () () a -> Const2 () () a -> m' (Const2 () () a)
86+ f _ (Const2 ()) = do
87+ notReadyUntil =<< delay 0.5 =<< getPostBuild
61− el "h1" $ text "Bad"
88+ text "Done"
89+ return $ Const2 ()
90+ postBuild <- getPostBuild
91+ traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild
92+ return ()
62 el "div" $ do
93 el "div" $ do
63 draw <- button "Draw"
94 draw <- button "Draw"
64 widgetHold blank $ ffor draw $ \_ -> do
95 widgetHold blank $ ffor draw $ \_ -> do
65 postBuild <- getPostBuild
96 postBuild <- getPostBuild
66 widgetHold (text "Loading...") $ slow <$ postBuild
97 widgetHold (text "Loading...") $ slow <$ postBuild
67 return ()
98 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 ()
74− el "h1" $ text "Good"
75− el "div" $ do
76− draw <- button "Draw"
77− widgetHold blank $ ffor draw $ \_ -> do
78− (df0, _) <- buildDomFragment $ text "Loading..."
79− (df', (doneBuilding, _)) <- buildDomFragment $ do
80− slow
81− postBuild <- getPostBuild
82− return (postBuild, ())
83− mountDomFragment df0 $ df' <$ doneBuilding
84− postBuild <- getPostBuild
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.
86 return ()
99 return ()
100+
101+instance {-# INCOHERENT #-} (Show (f a), Show (f b)) => ShowTag (EitherTag a b) f where
102+ showTagToShow e _ = case e of
103+ LeftTag -> id
104+ RightTag -> id