@@ -1,6 +1,9 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE ScopedTypeVariables #-}
33{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
47import Control.Monad
58import Control.Monad.Trans
69import Reflex.Dom
@@ -8,8 +11,13 @@ import qualified Data.Text as T
811import Control.Concurrent
912
1013import Control.Monad.State.Strict
14+import Data.Functor.Misc
1115import Data.Monoid
1216import 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
1321
1422main :: IO ()
1523main = mainWidget w
@@ -17,7 +25,7 @@ main = mainWidget w
1725w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()
1826w = do
1927 let slow :: forall m'. MonadWidget t m' => m' ()
20− {-
28+ {-
2129 performEventChain = do
2230 postBuild <- delay 0 =<< getPostBuild
2331 rec let maxN = 10000
@@ -26,8 +34,8 @@ w = do
2634 pausedUntil $ ffilter (==maxN) n'
2735 _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
2836 return ()
29− -}
30− {-
37+ -}
38+ {- Many dyns
3139 slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
3240 where maxDepth = 6 :: Int
3341 go 0 = blank
@@ -38,19 +46,21 @@ w = do
3846 elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
3947 elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
4048 elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
41− -}
42− {-
49+ -}
50+ {- Many elDynAttrs
4351 slow = do
4452 let size = 64
4553 replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do
4654 replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank
4755 -}
56+ {- Many dynTexts
4857 slow = el "table" $ do
4958 let size = 64
5059 replicateM_ size $ el "tr" $ do
5160 replicateM_ size $ el "td" $ do
5261 dynText $ pure "."
53− {-
62+ -}
63+ {- Many simultaneous performEvents
5464 slow = do
5565 postBuild <- getPostBuild
5666 replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
@@ -58,29 +68,37 @@ w = do
5868 _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
5969 return ()
6070 -}
61− el "h1" $ text "Bad"
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
88+ text "Done"
89+ return $ Const2 ()
90+ postBuild <- getPostBuild
91+ traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild
92+ return ()
6293 el "div" $ do
6394 draw <- button "Draw"
6495 widgetHold blank $ ffor draw $ \_ -> do
6596 postBuild <- getPostBuild
6697 widgetHold (text "Loading...") $ slow <$ postBuild
6798 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.
8699 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