Add some more stuff to test/prebuild.hs

test/prebuild.hs

@@ -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