@@ -0,0 +1,273 @@
1+{-# LANGUAGE RecursiveDo, ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+
3+module Reflex.Bench.Focused where
4+
5+import Reflex
6+import Reflex.TestPlan
7+
8+import Control.Monad.Fix
9+import Control.Monad
10+import Control.Applicative
11+import Data.Foldable
12+import Data.Traversable
13+
14+import Data.Maybe
15+import Data.Map (Map)
16+import qualified Data.Map as Map
17+
18+import Data.Tuple
19+import Data.List
20+import Data.List.Split
21+
22+import Prelude
23+
24+mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
25+mergeTree n es | length es <= n = sum' es
26+ | otherwise = mergeTree n subTrees
27+ where
28+ merges = chunksOf n es
29+ subTrees = map sum' merges
30+ sum' = fmap sum . mconcat . fmap (fmap (:[]) )
31+
32+mergeListDyn :: (Reflex t, MonadHold t m) => [Dynamic t a] -> m (Dynamic t [a])
33+mergeListDyn dyns = traverse (mapDyn pure) dyns >>= mconcatDyn
34+
35+mergeTreeDyn :: (Num a, Reflex t, MonadHold t m, MonadFix m) => Int -> [Dynamic t a] -> m (Dynamic t a)
36+mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
37+ | otherwise = traverse sumDyns merges >>= mergeTreeDyn n
38+ where
39+ merges = chunksOf n dyns
40+ sumDyns ds = mergeListDyn ds >>= mapDyn sum
41+
42+-- N events all firing for N frames
43+continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
44+continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
45+
46+-- Fire N events once every P frames for total N frames (interspersed evenly)
47+occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
48+occasional n period frames = traverse plan $ zipWith occs [1..] phases
49+ where
50+ phases = take (fromIntegral n) $ concat (repeat [1..period])
51+ occs i phase = (, i) <$> [1, phase+1..frames]
52+
53+-- Event which never fires (but isn't 'never')
54+never' :: TestPlan t m => m (Event t Word)
55+never' = plan []
56+
57+-- Event which fires once on first frame
58+event :: TestPlan t m => m (Event t Word)
59+event = plan [(1, 0)]
60+
61+-- Event which fires constantly over N frames
62+events :: TestPlan t m => Word -> m (Event t Word)
63+events n = plan $ (\i -> (i, i)) <$> [1..n]
64+
65+-- N events all originating from one event
66+fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
67+fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
68+
69+-- Create an Event with a Map which is dense to size N
70+denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
71+denseMap n = plan [(1, m)] where
72+ m = Map.fromList $ zip [1..n] [1..n]
73+
74+fmapChain :: Reflex t => Word -> Event t Word -> (Event t Word)
75+fmapChain 0 e = e
76+fmapChain n e = fmapChain (n - 1) (fmap (+1) e)
77+
78+mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
79+mapDynChain 0 d = return d
80+mapDynChain n d = mapDynChain (n - 1) =<< mapDyn (+1) d
81+
82+joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
83+joinDynChain 0 d = return d
84+joinDynChain n d = joinDynChain (n - 1) =<< joinDyn <$> mapDyn (const d) d
85+
86+combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
87+combineDynChain 0 d = return d
88+combineDynChain n d = combineDynChain (n - 1) =<< combineDyn (+) d d
89+
90+pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
91+pingPong e1 e2 = do
92+ rec
93+ d <- foldDyn (const swap) (e1, e2) e
94+ let e = switch (fst <$> current d)
95+ return e
96+
97+switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
98+switchFactors 0 e = return e
99+switchFactors i e = do
100+ b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
101+ switchFactors (i - 1) (switch b)
102+
103+switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
104+switchChain 0 e = return e
105+switchChain i e = switchChain (i - 1) =<< pingPong e ((+1) <$> e)
106+
107+switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
108+switchChain2 0 e = return e
109+switchChain2 i e = switchChain2 (i - 1) =<< pingPong e ((+1) <$> leftmost [e, e])
110+
111+switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
112+switchPromptlyChain 0 e = return e
113+switchPromptlyChain i e = do
114+ d <- holdDyn e (e <$ e)
115+ switchPromptlyChain (i - 1) (switchPromptlyDyn d)
116+
117+coinChain :: Reflex t => Word -> Event t Word -> Event t Word
118+coinChain 0 e = e
119+coinChain n e = coinChain (n - 1) $ coincidence (e <$ e)
120+
121+pullChain :: Reflex t => Word -> Behavior t Word -> Behavior t Word
122+pullChain 0 b = b
123+pullChain n b = pullChain (n - 1) $ (+1) <$> b
124+
125+-- | Data type for a collection (a map) which is updated by providing differences
126+data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
127+
128+-- This will hopefully become a primitive (faster!)
129+switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
130+switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
131+
132+switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a))
133+switchMergeBehaviors mapChanges = pull <$> joinMap <$> holdMap mapChanges
134+ where joinMap m = traverse sample =<< sample m
135+
136+-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
137+holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
138+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes
139+ where
140+ modify k Nothing items = Map.delete k items
141+ modify k (Just item) items = Map.insert k item items
142+
143+
144+-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
145+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
146+holdMap = (current <$>) . holdMapDyn
147+
148+increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
149+increasingMerge xs = do
150+ e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
151+ return (UpdatedMap Map.empty e)
152+ where
153+ reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
154+
155+decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
156+decreasingMerge xs = do
157+ e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
158+ return (UpdatedMap initial e)
159+ where
160+ initial = Map.fromList $ zip [1..] xs
161+ reset = Just <$> initial
162+
163+modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
164+modifyMerge xs = do
165+ e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
166+ return (UpdatedMap initial e)
167+ where
168+ initial = Map.fromList $ zip [1..] xs
169+
170+countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
171+countMany = traverse (fmap current . count)
172+
173+countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
174+countManyDyn = traverse count
175+
176+-- Given a function which creates a sub-network (from a single event)
177+-- Create a plan which uses a switch to substitute it
178+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
179+switches numFrames f = do
180+ es <- events numFrames
181+ switch <$> hold never (makeEvents es)
182+ where
183+ makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
184+
185+-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
186+-- the other, which we're only interested in time for running frames
187+subscribing :: Word -> Word -> [(String, TestCase)]
188+subscribing n frames =
189+ [ testE "fmapFan merge" $ switches frames (return . mergeList . fmapFan n)
190+ , testE "fmapFan/mergeTree" $ switches frames (return . mergeTree 8 . fmapFan n)
191+ , testE "fmapChain" $ switches frames (return . fmapChain n)
192+ , testE "switchChain" $ switches frames (switchChain n)
193+ , testE "switchPromptlyChain" $ switches frames (switchPromptlyChain n)
194+ , testE "switchFactors" $ switches frames (switchFactors n)
195+ , testE "coincidenceChain" $ switches frames (return . coinChain n)
196+ ]
197+
198+
199+-- Set of benchmark to test specifically merging dynamic collections
200+-- a pattern which occurs frequently in reflex-dom collections
201+merging :: Word -> [(String, TestCase)]
202+merging n =
203+ [ testE "static events" $ mergeList <$> sparse
204+ , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
205+ , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
206+ , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
207+
208+ , testB "static behaviors" $ pull . traverse sample <$> counters
209+ , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
210+ , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
211+ , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
212+ ]
213+
214+ where
215+ sparse :: TestPlan t m => m [Event t Word]
216+ sparse = fmap (fmap (+1)) <$> occasional n 8 n
217+
218+ counters :: TestPlan t m => m [Behavior t Int]
219+ counters = countMany =<< sparse
220+
221+dynamics :: Word -> [(String, TestCase)]
222+dynamics n =
223+ [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
224+ , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
225+ , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
226+ , testE "dense mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< dense
227+ , testE "sparse mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< sparse
228+ , testE "mergeDyn" $ fmap updated $ mapDyn sum =<< mergeListDyn =<< sparse
229+ ] where
230+ d :: TestPlan t m => m (Dynamic t Word)
231+ d = count =<< events 10
232+
233+ sparse, dense :: TestPlan t m => m [Dynamic t Int]
234+ sparse = countManyDyn =<< occasional n 8 16
235+ dense = countManyDyn =<< continuous n 2
236+
237+
238+firing :: Word -> [(String, TestCase)]
239+firing n =
240+ [ testE "fmapChain" $ fmapChain n <$> e
241+ , testE "switchChain2" $ switchChain2 n =<< e
242+ , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
243+ , testE "switchFactors" $ switchFactors n =<< e
244+ , testE "coincidenceChain" $ coinChain n <$> e
245+
246+ , testE "dense mergeTree" $ mergeTree 8 <$> dense
247+ , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
248+ , testE "runFrame" $ events n
249+ , testB "sum counters" $ do
250+ counts <- counters
251+ return $ pull $ sum <$> traverse sample counts
252+
253+ , testB "pullChain" $ pullChain n . current <$> (count =<< events 4)
254+ , testB "pullChain2" $ do
255+ e' <- events 4
256+ b <- hold (constant 0) $ leftmost
257+ [ constant 0 <$ ffilter (==4) e'
258+ , pushAlways (const $ pullChain n <$> hold 0 e') e'
259+ ]
260+ return (join b)
261+ , testB "counters/pullTree" $ mergeTree 8 <$> counters
262+ ]
263+ where
264+ e :: TestPlan t m => m (Event t Word)
265+ e = events 10
266+
267+ dense, sparse :: TestPlan t m => m [Event t Word]
268+ dense = continuous n 2
269+ sparse = occasional n 8 16
270+
271+ counters :: TestPlan t m => m [Behavior t Int]
272+ counters = countMany =<< sparse
273+