@@ -0,0 +1,121 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE RecursiveDo #-}
6+
7+module Main where
8+
9+import Control.Lens
10+import Control.Monad
11+import Control.Monad.Fix
12+import qualified Data.Dependent.Map as DMap
13+import Data.Dependent.Sum
14+import Data.These
15+import Data.Monoid
16+
17+import Reflex
18+import Test.Run
19+
20+pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)
21+pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))
22+
23+foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)
24+foldedDyn f d = fmap join $ flip buildDynamic never $ do
25+ a <- sample (current d)
26+ foldDyn f a (updated d)
27+
28+scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])
29+scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure
30+
31+scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])
32+scanInnerDyns d = do
33+ scans <- scannedDyn d
34+ return (join (fmap distributeListOverDynPure scans))
35+
36+
37+main :: IO ()
38+main = do
39+
40+ r <- last <$> runAppB testInnerHoldsE (Just <$> [1..4])
41+ -- [[[0,1,2],[1,2],[2]]]]
42+
43+ -- r <- runAppB testScan counter
44+
45+ -- r <- runAppB testStrictness (fmap Just [1..9])
46+
47+
48+ print r
49+ return ()
50+
51+ where
52+ counter = fmap Just [1..9] <> [Nothing]
53+ eithers = fmap Just [ Left 1, Left 2, Right 3, Left 4, Left 5, Right 6, Right 7, Right 8, Left 9 ] <> [Nothing]
54+
55+testIdentity :: (Reflex t, MonadHold t m, MonadFix m)
56+ => Event t Int -> m (Behavior t Int)
57+testIdentity e = do
58+ d <- holdDyn 0 e
59+ d' <- pushDyn return d
60+ d'' <- pushDyn return d'
61+
62+ return (current d'')
63+
64+testStrictness :: (Reflex t, MonadHold t m, MonadFix m)
65+ => Event t Int -> m (Behavior t Int)
66+testStrictness e = do
67+
68+ rec
69+ d'' <- pushDyn return d'
70+ d' <- pushDyn return d
71+ d <- holdDyn 0 e
72+
73+ return (current d'')
74+
75+
76+testScan :: (Reflex t, MonadHold t m, MonadFix m)
77+ => Event t Int -> m (Behavior t [Int])
78+testScan e = do
79+ d <- holdDyn 0 e
80+ scan <- scannedDyn d
81+ return (current scan)
82+
83+testFactor :: (Reflex t, MonadHold t m, MonadFix m)
84+ => Event t (Either Int Int) -> m (Behavior t (Either Int Int))
85+testFactor e = do
86+ d <- holdDyn (Left 0) e
87+
88+ eithers <- eitherDyn d
89+ return $ current (join (fmap unFactor eithers))
90+
91+ where
92+ unFactor = either (fmap Left) (fmap Right)
93+
94+testInnerHolds :: (Reflex t, MonadHold t m, MonadFix m)
95+ => Event t Int -> m (Behavior t [Int])
96+testInnerHolds e = do
97+ d <- holdDyn 0 e
98+
99+ d' <- pushDyn (\a -> foldDyn (:) [a] (updated d)) d
100+ return $ current (join d')
101+
102+testInnerHoldsE :: forall t m. (Reflex t, MonadHold t m, MonadFix m)
103+ => Event t Int -> m (Behavior t [[Int]])
104+testInnerHoldsE e = do
105+ initial <- f 0
106+ d <- foldDyn snoc [initial] updates
107+ return $ current (join (fmap distributeListOverDynPure d))
108+ where
109+ f :: forall n. (MonadHold t n, MonadFix n) => Int -> n (Dynamic t [Int])
110+ f a = foldDyn snoc [a] e
111+ updates = pushAlways f e
112+
113+ snoc x xs = xs ++ [x]
114+
115+testInnerHolds1 :: (Reflex t, MonadHold t m, MonadFix m)
116+ => Event t Int -> m (Behavior t [[Int]])
117+testInnerHolds1 e = do
118+ d <- fmap pure <$> holdDyn 0 e
119+
120+ d' <- pushDyn (\a -> foldDyn (flip mappend) a (updated d)) d
121+ current <$> scanInnerDyns d'