@@ -0,0 +1,267 @@
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+-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
144+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
145+holdMap = (current <$>) . holdMapDyn
146+
147+increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
148+increasingMerge xs = do
149+ e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
150+ return (UpdatedMap Map.empty e)
151+ where
152+ reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
153+
154+decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
155+decreasingMerge xs = do
156+ e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
157+ return (UpdatedMap initial e)
158+ where
159+ initial = Map.fromList $ zip [1..] xs
160+ reset = Just <$> initial
161+
162+modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
163+modifyMerge xs = do
164+ e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
165+ return (UpdatedMap initial e)
166+ where
167+ initial = Map.fromList $ zip [1..] xs
168+
169+countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
170+countMany = traverse (fmap current . count)
171+
172+countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
173+countManyDyn = traverse count
174+
175+-- Given a function which creates a sub-network (from a single event)
176+-- Create a plan which uses a switch to substitute it
177+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
178+switches numFrames f = do
179+ es <- events numFrames
180+ switch <$> hold never (makeEvents es)
181+ where
182+ makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
183+
184+-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
185+-- the other, which we're only interested in time for running frames
186+subscribing :: Word -> Word -> [(String, TestCase)]
187+subscribing n frames =
188+ [ testE "fmapFan merge" $ switches frames (return . mergeList . fmapFan n)
189+ , testE "fmapFan/mergeTree" $ switches frames (return . mergeTree 8 . fmapFan n)
190+ , testE "fmapChain" $ switches frames (return . fmapChain n)
191+ , testE "switchChain" $ switches frames (switchChain n)
192+ , testE "switchPromptlyChain" $ switches frames (switchPromptlyChain n)
193+ , testE "switchFactors" $ switches frames (switchFactors n)
194+ , testE "coincidenceChain" $ switches frames (return . coinChain n)
195+ ]
196+
197+-- Set of benchmark to test specifically merging dynamic collections
198+-- a pattern which occurs frequently in reflex-dom collections
199+merging :: Word -> [(String, TestCase)]
200+merging n =
201+ [ testE "static events" $ mergeList <$> sparse
202+ , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
203+ , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
204+ , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
205+
206+ , testB "static behaviors" $ pull . traverse sample <$> counters
207+ , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
208+ , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
209+ , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
210+ ]
211+ where
212+ sparse :: TestPlan t m => m [Event t Word]
213+ sparse = fmap (fmap (+1)) <$> occasional n 8 n
214+
215+ counters :: TestPlan t m => m [Behavior t Int]
216+ counters = countMany =<< sparse
217+
218+dynamics :: Word -> [(String, TestCase)]
219+dynamics n =
220+ [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
221+ , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
222+ , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
223+ , testE "dense mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< dense
224+ , testE "sparse mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< sparse
225+ , testE "mergeDyn" $ fmap updated $ mapDyn sum =<< mergeListDyn =<< sparse
226+ ] where
227+ d :: TestPlan t m => m (Dynamic t Word)
228+ d = count =<< events 10
229+
230+ sparse, dense :: TestPlan t m => m [Dynamic t Int]
231+ sparse = countManyDyn =<< occasional n 8 16
232+ dense = countManyDyn =<< continuous n 2
233+
234+firing :: Word -> [(String, TestCase)]
235+firing n =
236+ [ testE "fmapChain" $ fmapChain n <$> e
237+ , testE "switchChain2" $ switchChain2 n =<< e
238+ , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
239+ , testE "switchFactors" $ switchFactors n =<< e
240+ , testE "coincidenceChain" $ coinChain n <$> e
241+ , testE "dense mergeTree" $ mergeTree 8 <$> dense
242+ , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
243+ , testE "runFrame" $ events n
244+ , testB "sum counters" $ do
245+ counts <- counters
246+ return $ pull $ sum <$> traverse sample counts
247+
248+ , testB "pullChain" $ pullChain n . current <$> (count =<< events 4)
249+ , testB "pullChain2" $ do
250+ e' <- events 4
251+ b <- hold (constant 0) $ leftmost
252+ [ constant 0 <$ ffilter (==4) e'
253+ , pushAlways (const $ pullChain n <$> hold 0 e') e'
254+ ]
255+ return (join b)
256+ , testB "counters/pullTree" $ mergeTree 8 <$> counters
257+ ]
258+ where
259+ e :: TestPlan t m => m (Event t Word)
260+ e = events 10
261+
262+ dense, sparse :: TestPlan t m => m [Event t Word]
263+ dense = continuous n 2
264+ sparse = occasional n 8 16
265+
266+ counters :: TestPlan t m => m [Behavior t Int]
267+ counters = countMany =<< sparse