git.iko.soy/patch
on 144de62 help sign in
patch/test/Reflex/Bench/Focused.hs
369 lines 13 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)
133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
136pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
137pingPong e1 e2 = do
138 rec
139 d <- foldDyn (const swap) (e1, e2) e
140 let e = switch (fst <$> current d)
141 return e
143switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
144switchFactors 0 e = return e
145switchFactors i e = do
146 b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
147 switchFactors (i - 1) (switch b)
150switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
151switchChain = iterM (\e -> pingPong e ((+1) <$> e))
154switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
155switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))
157switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
158switchPromptlyChain = iterM $ \e ->
159 switchPromptlyDyn <$> holdDyn e (e <$ e)
162coinChain :: Reflex t => Word -> Event t Word -> Event t Word
163coinChain = iter $ \e -> coincidence (e <$ e)
165fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
166fanMergeChain width = iter $ fanMerge width
168fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
169fmapFanMergeChain width = iter $ fmapFanMerge width
171-- | Data type for a collection (a map) which is updated by providing differences
172data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
174-- This will hopefully become a primitive (faster!)
175switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
176switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
178-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
179-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)
181switchMergeBehaviors :: 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))
182switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges
183 where joinMap m = traverse sample =<< sample m
185-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
186holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
187holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes
189 where
190 modify k Nothing items = Map.delete k items
191 modify k (Just item) items = Map.insert k item items
194-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
195holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
196holdMap = (current <$>) . holdMapDyn
199increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
200increasingMerge xs = do
201 e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
202 return (UpdatedMap Map.empty e)
203 where
204 reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
206decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
207decreasingMerge xs = do
208 e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
209 return (UpdatedMap initial e)
210 where
211 initial = Map.fromList $ zip [1..] xs
212 reset = Just <$> initial
214modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
215modifyMerge xs = do
216 e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
217 return (UpdatedMap initial e)
218 where
219 initial = Map.fromList $ zip [1..] xs
222countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
223countMany = traverse (fmap current . count)
225countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
226countManyDyn = traverse count
229-- Given a function which creates a sub-network (from a single event)
230-- Create a plan which uses a switch to substitute it
231switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
232switches numFrames f = do
233 es <- events numFrames
234 switch <$> hold never (makeEvents es)
236 where
237 makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
241-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
242-- the other, which we're only interested in time for running frames
243subscribing :: Word -> Word -> [(String, TestCase)]
244subscribing n frames =
245 [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n
246 , testSub "fanMerge" $ return . fanMerge n
247 , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n
248 , testSub "fmapChain" $ return . fmapChain n
249 , testSub "switchChain" $ switchChain n
250 , testSub "switchPromptlyChain" $ switchPromptlyChain n
251 , testSub "switchFactors" $ switchFactors n
252 , testSub "coincidenceChain" $ return . coinChain n
253 ]
255 where
256 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)
257 testSub name test = testE name (switches frames test)
259-- Set of benchmark to test specifically merging dynamic collections
260-- a pattern which occurs frequently in reflex-dom collections
261merging :: Word -> [(String, TestCase)]
262merging n =
263 [ testE "static events" $ mergeList <$> sparse
264 , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
265 , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
266 , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
268 , testB "static behaviors" $ pull . traverse sample <$> counters
269 , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
270 , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
271 , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
274 -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse
275 -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse
276 -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse
277 ]
279 where
280 sparse :: TestPlan t m => m [Event t Word]
281 sparse = fmap (fmap (+1)) <$> occasional n 8 n
283 counters :: TestPlan t m => m [Behavior t Int]
284 counters = countMany =<< sparse
288fans :: Word -> [(String, TestCase)]
289fans n =
290 [ testE "fanMapChain" $ fanMergeChain n 10 <$> e
291 , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e
293 , testE "fanMerge " $ fanMerge n <$> events n
295 , testE "fmapFanMerge " $ fmapFanMerge n <$> events n
296 , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])
298 ]
299 where
301 e :: TestPlan t m => m (Event t Word)
302 e = events 100
307dynamics :: Word -> [(String, TestCase)]
308dynamics n =
309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
314 , testE "mergeDyn" $ fmap (updated . fmap sum . mergeListDyn) sparse
315 ] where
317 d :: TestPlan t m => m (Dynamic t Word)
318 d = count =<< events 10
320 sparse, dense :: TestPlan t m => m [Dynamic t Int]
321 sparse = countManyDyn =<< occasional n 8 16
322 dense = countManyDyn =<< continuous n 2
325firing :: Word -> [(String, TestCase)]
326firing n =
327 [ testE "fmapChain" $ fmapChain n <$> e
328 , testE "switchChain2" $ switchChain2 n =<< e
329 , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
330 , testE "switchFactors" $ switchFactors n =<< e
331 , testE "coincidenceChain" $ coinChain n <$> e
333 , testE "dense mergeTree" $ mergeTree 8 <$> dense
334 , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
336 -- Triggers test failure in Spider
337 --, testE "runFrame" $ events n
339 , testB "sum counters" $ do
340 counts <- counters
341 return $ pull $ sum <$> traverse sample counts
343 , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4)
344 , testB "pullChain2" $ do
345 es <- events 4
346 e' <- plan [(0, ())]
348 b <- hold (constant 0) $
349 pushAlways (const $ fmapChain n <$> hold 0 es) e'
351 return (join b)
352 , testB "counters/pullTree" $ mergeTree 8 <$> counters
354 ]
355 where
356 e :: TestPlan t m => m (Event t Word)
357 e = events 10
359 dense, sparse :: TestPlan t m => m [Event t Word]
360 dense = continuous n 2
361 sparse = occasional n 8 16
363 counters :: TestPlan t m => m [Behavior t Int]
364 counters = countMany =<< sparse