@@ -1,127 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−import Control.Monad
9−import Control.Monad.Identity
10−import Control.Monad.Trans
11−import Reflex.Dom
12−import qualified Data.Text as T
13−import Control.Concurrent
14−
15−import Control.Monad.State.Strict
16−import Data.Functor.Misc
17−import Data.Monoid
18−import Data.Word
19−import qualified Data.Map as Map
20−import qualified Data.Dependent.Map as DMap
21−import Data.Dependent.Sum
22−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
23−
24−main :: IO ()
25−main = mainWidget w
26−
27−w :: forall t m. (MonadWidget t m, DomRenderHook t m, MountableDomBuilder t m) => m ()
28−w = do
29− let slow :: forall m'. (MonadWidget t m', DomRenderHook t m') => m' ()
30− {-
31− performEventChain = do
32− postBuild <- delay 0 =<< getPostBuild
33− rec let maxN = 10000
34− n = leftmost [0 <$ postBuild, ffilter (<=maxN) $ succ <$> n']
35− n' <- performEvent $ return <$> n
36− pausedUntil $ ffilter (==maxN) n'
37− _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n
38− return ()
39− -}
40−-- {- Many dyns
41− slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth
42− where maxDepth = 6 :: Int
43− go 0 = blank
44− go n = void $ dyn $ pure $ do
45− let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"
46− s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor
47− elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n
48− elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n
49− elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n
50− elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n
51−-- -}
52− {- Many elDynAttrs
53− slow = do
54− let size = 64
55− replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do
56− replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank
57− -}
58− {- Many dynTexts
59− slow = el "table" $ do
60− let size = 64
61− replicateM_ size $ el "tr" $ do
62− replicateM_ size $ el "td" $ do
63− dynText $ pure "."
64− -}
65− {- Many simultaneous performEvents
66− slow = do
67− postBuild <- getPostBuild
68− replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild
69− done <- performEvent $ return () <$ postBuild
70− _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done
71− return ()
72− -}
73− {-
74− slow = do
75− postBuild <- getPostBuild
76− postBuild' <- performEvent . (return () <$) =<< performEvent . (return () <$) =<< getPostBuild
77− let f x = Map.fromList [(n, x) | n <- [1 :: Int .. 4096]]
78− listHoldWithKey (f False) (f (Just True) <$ postBuild') $ \k -> \case
79− False -> do
80− text "X "
81− notReadyUntil =<< getPostBuild
82− True -> do
83− text ". "
84− return ()
85− -}
86− {-
87− slow = do
88− let f :: forall a. EitherTag () () a -> Const2 () () a -> m' (Const2 () () a)
89− f _ (Const2 ()) = do
90− notReadyUntil =<< delay 0.5 =<< getPostBuild
91− text "Done"
92− return $ Const2 ()
93− postBuild <- getPostBuild
94− traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild
95− return ()
96− -}
97− {-
98− slow = do
99− let h x = do
100− liftIO $ putStrLn "render hook"
101− result <- x
102− liftIO $ putStrLn "render hook done"
103− return result
104− f :: forall a. Const2 () () a -> Identity a -> m' (Identity a)
105− f (Const2 ()) (Identity ()) = do
106− liftIO $ putStrLn "f"
107− widgetHold notReady . (blank <$) =<< delay 0.1 =<< getPostBuild
108− liftIO $ putStrLn "f done"
109− return $ Identity ()
110− withRenderHook h $ do
111− postBuild <- getPostBuild
112− _ <- traverseDMapWithKeyWithAdjust f mempty $ PatchDMap (DMap.singleton (Const2 () :: Const2 () () ()) (ComposeMaybe $ Just $ Identity ())) <$ postBuild
113− return ()
114− -}
115− el "div" $ do
116− draw <- button "Draw"
117− widgetHold blank $ ffor draw $ \_ -> do
118− _ <- untilReady (text "Loading...") slow
119− return ()
120− return ()
121−
122−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
123−instance {-# INCOHERENT #-} (Show (f a), Show (f b)) => ShowTag (EitherTag a b) f where
124− showTagToShow e _ = case e of
125− LeftTag -> id
126− RightTag -> id
127−#endif