git.iko.soy/reflex
on develop help sign in
reflex/test/Reflex/Bench/Focused.hs
381 lines 14 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RecursiveDo #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TypeSynonymInstances #-}
12module Reflex.Bench.Focused where
14import Reflex
15import Reflex.TestPlan
17import Control.Applicative
18import Control.Monad
19import Control.Monad.Fix
20import Control.Monad.Identity
21import Data.Traversable (for, traverse)
23import qualified Data.Dependent.Map as DMap
24import Data.Map (Map)
25import qualified Data.Map as Map
26import Data.Maybe
28import Data.Functor.Misc
30import Data.List
31import Data.List.Split
32import Data.Tuple
34import Data.Monoid
35import Data.Word
37import Control.DeepSeq
39import Prelude hiding (concat, sum)
42mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
43mergeTree n es | length es <= n = sum' es
44 | otherwise = mergeTree n subTrees
45 where
46 merges = chunksOf n es
47 subTrees = map sum' merges
48 sum' = fmap sum . mconcat . fmap (fmap (:[]) )
50mergeListDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
51mergeListDyn = mconcat . fmap (fmap pure)
53mergeTreeDyn :: (Num a, Reflex t) => Int -> [Dynamic t a] -> Dynamic t a
54mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
55 | otherwise = mergeTreeDyn n $ fmap sumDyns merges
56 where
57 merges = chunksOf n dyns
58 sumDyns = fmap sum . mergeListDyn
62-- N events all firing for N frames
63continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
64continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
66-- Fire N events once every P frames for total N frames (interspersed evenly)
67occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
68occasional n period frames = traverse plan $ zipWith occs [1..] phases
69 where
70 phases = take (fromIntegral n) $ concat (repeat [1..period])
71 occs i phase = (, i) <$> [1, phase+1..frames]
75-- Event which never fires (but isn't 'never')
76never' :: TestPlan t m => m (Event t Word)
77never' = plan []
80-- Event which fires once on first frame
81event :: TestPlan t m => m (Event t Word)
82event = plan [(1, 0)]
84-- Event which fires constantly over N frames
85events :: TestPlan t m => Word -> m (Event t Word)
86events n = plan $ (\i -> (i, i)) <$> [1..n]
89-- N events all originating from one event
90fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
91fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
94-- Make a fan using the value in the event converting it to a singleton Map
95-- use a fan of size n (key is the value mod n)
96fanMerge :: Reflex t => Word -> Event t Word -> Event t Word
97fanMerge n e = leftmost $ s <$> [0..n - 1] where
98 s k = select f (Const2 k)
99 f = fan (toMap <$> e)
100 toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)
102-- Dumb version of the above using simple fmapMaybe to filter
103fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word
104fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where
105 s k = flip fmapMaybe e $ \j -> if k == j `mod` n
106 then Just k
107 else Nothing
111-- Create an Event with a Map which is dense to size N
112denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
113denseMap n = plan [(1, m)] where
114 m = Map.fromList $ zip [1..n] [1..n]
116iter :: (a -> a) -> Word -> a -> a
117iter _ 0 a = a
118iter f n a = iter f (n - 1) (f a)
120iterM :: Monad m => (a -> m a) -> Word -> a -> m a
121iterM _ 0 a = return a
122iterM f n a = iterM f (n - 1) =<< f a
124fmapChain :: (Functor f) => Word -> f Word -> f Word
125fmapChain = iter (fmap (+1))
127mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
128mapDynChain = iterM (return . fmap (+1))
130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
133holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))
136buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
137buildDynChain = iterM (\d -> do
138 let b = fmap (+1) (current d)
139 e = fmap (*2) (updated d)
140 buildDynamic (sample b) e)
143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
146pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
147pingPong e1 e2 = do
148 rec
149 d <- foldDyn (const swap) (e1, e2) e
150 let e = switch (fst <$> current d)
151 return e
153switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
154switchFactors 0 e = return e
155switchFactors i e = do
156 b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
157 switchFactors (i - 1) (switch b)
160switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
161switchChain = iterM (\e -> pingPong e ((+1) <$> e))
164switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
165switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))
167switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
168switchPromptlyChain = iterM $ \e ->
169 switchPromptlyDyn <$> holdDyn e (e <$ e)
172coinChain :: Reflex t => Word -> Event t Word -> Event t Word
173coinChain = iter $ \e -> coincidence (e <$ e)
175fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
176fanMergeChain width = iter $ fanMerge width
178fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
179fmapFanMergeChain width = iter $ fmapFanMerge width
181-- | Data type for a collection (a map) which is updated by providing differences
182data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
184-- This will hopefully become a primitive (faster!)
185switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
186switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
188-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
189-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)
191switchMergeBehaviors :: 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))
192switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges
193 where joinMap m = traverse sample =<< sample m
195-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
196holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
197holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes
199 where
200 modify k Nothing items = Map.delete k items
201 modify k (Just item) items = Map.insert k item items
204-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
205holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
206holdMap = (current <$>) . holdMapDyn
209increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
210increasingMerge xs = do
211 e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
212 return (UpdatedMap Map.empty e)
213 where
214 reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
216decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
217decreasingMerge xs = do
218 e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
219 return (UpdatedMap initial e)
220 where
221 initial = Map.fromList $ zip [1..] xs
222 reset = Just <$> initial
224modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
225modifyMerge xs = do
226 e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
227 return (UpdatedMap initial e)
228 where
229 initial = Map.fromList $ zip [1..] xs
232countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
233countMany = traverse (fmap current . count)
235countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
236countManyDyn = traverse count
239-- Given a function which creates a sub-network (from a single event)
240-- Create a plan which uses a switch to substitute it
241switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
242switches numFrames f = do
243 es <- events numFrames
244 switch <$> hold never (makeEvents es)
246 where
247 makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
251-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
252-- the other, which we're only interested in time for running frames
253subscribing :: Word -> Word -> [(String, TestCase)]
254subscribing n frames =
255 [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n
256 , testSub "fanMerge" $ return . fanMerge n
257 , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n
258 , testSub "fmapChain" $ return . fmapChain n
259 , testSub "switchChain" $ switchChain n
260 , testSub "switchPromptlyChain" $ switchPromptlyChain n
261 , testSub "switchFactors" $ switchFactors n
262 , testSub "coincidenceChain" $ return . coinChain n
263 ]
265 where
266 testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
267 testSub name test = testE name (switches frames test)
269-- Set of benchmark to test specifically merging dynamic collections
270-- a pattern which occurs frequently in reflex-dom collections
271merging :: Word -> [(String, TestCase)]
272merging n =
273 [ testE "static events" $ mergeList <$> sparse
274 , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
275 , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
276 , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
278 , testB "static behaviors" $ pull . traverse sample <$> counters
279 , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
280 , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
281 , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
284 -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse
285 -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse
286 -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse
287 ]
289 where
290 sparse :: TestPlan t m => m [Event t Word]
291 sparse = fmap (fmap (+1)) <$> occasional n 8 n
293 counters :: TestPlan t m => m [Behavior t Int]
294 counters = countMany =<< sparse
298fans :: Word -> [(String, TestCase)]
299fans n =
300 [ testE "fanMapChain" $ fanMergeChain n 10 <$> e
301 , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e
303 , testE "fanMerge " $ fanMerge n <$> events n
305 , testE "fmapFanMerge " $ fmapFanMerge n <$> events n
306 , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])
308 ]
309 where
311 e :: TestPlan t m => m (Event t Word)
312 e = events 100
317dynamics :: Word -> [(String, TestCase)]
318dynamics n =
319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
321 , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d
322 , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d
323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
326 , testE "mergeDyn" $ fmap (updated . fmap sum . mergeListDyn) sparse
327 ] where
329 d :: TestPlan t m => m (Dynamic t Word)
330 d = count =<< events 10
332 sparse, dense :: TestPlan t m => m [Dynamic t Int]
333 sparse = countManyDyn =<< occasional n 8 16
334 dense = countManyDyn =<< continuous n 2
337firing :: Word -> [(String, TestCase)]
338firing n =
339 [ testE "fmapChain" $ fmapChain n <$> e
340 , testE "switchChain2" $ switchChain2 n =<< e
341 , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
342 , testE "switchFactors" $ switchFactors n =<< e
343 , testE "coincidenceChain" $ coinChain n <$> e
345 , testE "dense mergeTree" $ mergeTree 8 <$> dense
346 , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
348 -- Triggers test failure in Spider
349 --, testE "runFrame" $ events n
351 , testB "sum counters" $ do
352 counts <- counters
353 return $ pull $ sum <$> traverse sample counts
355 , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4)
356 , testB "pullChain2" $ do
357 es <- events 4
358 e' <- plan [(0, ())]
360 b <- hold (constant 0) $
361 pushAlways (const $ fmapChain n <$> hold 0 es) e'
363 return (join b)
364 , testB "counters/pullTree" $ mergeTree 8 <$> counters
366 ]
367 where
368 e :: TestPlan t m => m (Event t Word)
369 e = events 10
371 dense, sparse :: TestPlan t m => m [Event t Word]
372 dense = continuous n 2
373 sparse = occasional n 8 16
375 counters :: TestPlan t m => m [Behavior t Int]
376 counters = countMany =<< sparse