4a6ee12 · reflex · git.iko.soy

git.iko.soy/reflex

Update benchmarks and add tests

commit4a6ee12ed862f0ba7a03868aa14eae4e8cc00b87 authorOliver Batchelor <saulzar@gmail.com> dateTue 9 Feb 2016, 00:07 (11 years ago) parent5b5a1c8

9 files changed+603−56

compare with develop

unifiedsplit

bench/Main.hs+7−6 reflex.cabal+8−6 test/Reflex/Bench/Focused.hs+120−37 test/Reflex/Plan/Pure.hs+61 test/Reflex/Plan/Reflex.hs+5−4 test/Reflex/Test.hs+61 test/Reflex/Test/Micro.hs+298 test/Reflex/Test/RunAll.hs+43 test/Reflex/TestPlan.hs−3

bench/Main.hs+7−6

@@ -7,6 +7,7 @@ module Main where

77import Data.Functor.Misc

88import Control.Monad.Primitive

99import Control.Monad.IO.Class

10+import Control.Monad.Identity

1011import Data.Dependent.Sum

1112import Control.Concurrent.STM

1213import Control.Applicative

@@ -73,7 +74,7 @@ micros =

7374 (newEventWithTriggerRef >>= subscribePair)

7475 (\(subd, trigger) -> do

7576 Just key <- liftIO $ readIORef trigger

76− fireEvents [key :=> (42 :: Int)])

77+ fireEvents [key :=> Identity (42 :: Int)])

7778 , withSetupWHNF "fireEventsAndRead(head/merge1)"

7879 (setupMerge 1 >>= subscribePair)

7980 (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)

@@ -87,17 +88,17 @@ micros =

8788 (setupMerge 100 >>= subscribePair)

8889 (\(subd, t:riggers) -> do

8990 Just key <- liftIO $ readIORef t

90− fireEvents [key :=> (42 :: Int)])

91+ fireEvents [key :=> Identity (42 :: Int)])

9192 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev

92− , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample

93+ , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample

9394 ]

9495

9596setupMerge :: Int

96− -> SpiderHost (Event Spider (DM.DMap (Const2 Int a)),

97+ -> SpiderHost (Event Spider (DM.DMap (Const2 Int a) Identity),

9798 [IORef (Maybe (EventTrigger Spider a))])

9899setupMerge num = do

99100 (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef

100− let !m = DM.fromList [WrapArg (Const2 i) :=> v | (i,v) <- zip [0..] evs]

101+ let !m = DM.fromList [(Const2 i) :=> v | (i,v) <- zip [0..] evs]

101102 pure (merge m, triggers)

102103

103104subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)

@@ -107,4 +108,4 @@ fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider

107108 -> SpiderHost (Maybe b)

108109fireAndRead trigger val subd = do

109110 Just key <- liftIO $ readIORef trigger

110− fireEventsAndRead [key :=> val] $ readEvent subd >>= T.sequence

111+ fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= T.sequence

reflex.cabal+8−6

@@ -46,12 +46,11 @@ library

4646 other-extensions: TemplateHaskell

4747 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

4848

49−test-suite cross-impl

49+

50+test-suite all

5051 type: exitcode-stdio-1.0

51− main-is: Reflex/Test/CrossImpl.hs

52− other-modules:

53− Reflex.Pure

54− ghc-options: -O2 -main-is Reflex.Test.CrossImpl.test

52+ main-is: Reflex/Test/RunAll.hs

53+ ghc-options: -O2 -Wall

5554 hs-source-dirs: test

5655 build-depends:

5756 base,

@@ -60,7 +59,10 @@ test-suite cross-impl

6059 mtl,

6160 containers,

6261 dependent-map,

63− MemoTrie == 0.6.*

62+ dependent-sum,

63+ MemoTrie == 0.6.*,

64+ split

65+

6466

6567benchmark spider-bench

6668 type: exitcode-stdio-1.0

test/Reflex/Bench/Focused.hs+120−37

@@ -7,6 +7,7 @@ import Reflex.TestPlan

88import Control.Monad.Fix

99import Control.Monad

10+import Control.Monad.Identity

1011import Control.Applicative

1112import Data.Foldable

1213import Data.Traversable

@@ -14,6 +15,9 @@ import Data.Traversable

1415import Data.Maybe

1516import Data.Map (Map)

1617import qualified Data.Map as Map

18+import qualified Data.Dependent.Map as DMap

19+

20+import Data.Functor.Misc

1721

1822import Data.Tuple

1923import Data.List

@@ -21,6 +25,7 @@ import Data.List.Split

2125

2226import Prelude

2327

28+

2429mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a

2530mergeTree n es | length es <= n = sum' es

2631 | otherwise = mergeTree n subTrees

@@ -39,6 +44,8 @@ mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns

3944 merges = chunksOf n dyns

4045 sumDyns ds = mergeListDyn ds >>= mapDyn sum

4146

47+

48+

4249-- N events all firing for N frames

4350continuous :: TestPlan t m => Word -> Word -> m [Event t Word]

4451continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]

@@ -50,10 +57,13 @@ occasional n period frames = traverse plan $ zipWith occs [1..] phases

5057 phases = take (fromIntegral n) $ concat (repeat [1..period])

5158 occs i phase = (, i) <$> [1, phase+1..frames]

5259

60+

61+

5362-- Event which never fires (but isn't 'never')

5463never' :: TestPlan t m => m (Event t Word)

5564never' = plan []

5665

66+

5767-- Event which fires once on first frame

5868event :: TestPlan t m => m (Event t Word)

5969event = plan [(1, 0)]

@@ -62,30 +72,53 @@ event = plan [(1, 0)]

6272events :: TestPlan t m => Word -> m (Event t Word)

6373events n = plan $ (\i -> (i, i)) <$> [1..n]

6474

75+

6576-- N events all originating from one event

6677fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]

6778fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]

6879

80+

81+-- Make a fan using the value in the event converting it to a singleton Map

82+-- use a fan of size n (key is the value mod n)

83+fanMerge :: Reflex t => Word -> Event t Word -> Event t Word

84+fanMerge n e = leftmost $ s <$> [0..n - 1] where

85+ s k = select f (Const2 k)

86+ f = fan (toMap <$> e)

87+ toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)

88+

89+-- Dumb version of the above using simple fmapMaybe to filter

90+fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word

91+fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where

92+ s k = flip fmapMaybe e $ \j -> if (k == j `mod` n)

93+ then Just k

94+ else Nothing

95+

96+

97+

6998-- Create an Event with a Map which is dense to size N

7099denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))

71100denseMap n = plan [(1, m)] where

72101 m = Map.fromList $ zip [1..n] [1..n]

73102

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)

103+iter :: (a -> a) -> Word -> a -> a

104+iter _ 0 a = a

105+iter f n a = iter f (n - 1) (f a)

106+

107+iterM :: Monad m => (a -> m a) -> Word -> a -> m a

108+iterM _ 0 a = return a

109+iterM f n a = iterM f (n - 1) =<< f a

110+

111+fmapChain :: (Functor f) => Word -> f Word -> f Word

112+fmapChain = iter (fmap (+1))

77113

78114mapDynChain :: (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

115+mapDynChain = iterM (mapDyn (+1))

81116

82117joinDynChain :: (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

118+joinDynChain = iterM (\d -> joinDyn <$> mapDyn (const d) d)

85119

86120combineDynChain :: (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

121+combineDynChain = iterM (\d -> combineDyn (+) d d)

89122

90123pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)

91124pingPong e1 e2 = do

@@ -100,27 +133,27 @@ switchFactors i e = do

100133 b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)

101134 switchFactors (i - 1) (switch b)

102135

136+

103137switchChain :: (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)

138+switchChain = iterM (\e -> pingPong e ((+1) <$> e))

139+

106140

107141switchChain2 :: (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])

142+switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))

110143

111144switchPromptlyChain :: (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)

145+switchPromptlyChain = iterM $ \e ->

146+ switchPromptlyDyn <$> holdDyn e (e <$ e)

147+

116148

117149coinChain :: Reflex t => Word -> Event t Word -> Event t Word

118−coinChain 0 e = e

119−coinChain n e = coinChain (n - 1) $ coincidence (e <$ e)

150+coinChain = iter $ \e -> coincidence (e <$ e)

151+

152+fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word

153+fanMergeChain width = iter $ fanMerge width

120154

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

155+fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word

156+fmapFanMergeChain width = iter $ fmapFanMerge width

124157

125158-- | Data type for a collection (a map) which is updated by providing differences

126159data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))

@@ -129,6 +162,9 @@ data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))

129162switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))

130163switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges

131164

165+-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))

166+-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)

167+

132168switchMergeBehaviors :: 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))

133169switchMergeBehaviors mapChanges = pull <$> joinMap <$> holdMap mapChanges

134170 where joinMap m = traverse sample =<< sample m

@@ -136,6 +172,7 @@ switchMergeBehaviors mapChanges = pull <$> joinMap <$> holdMap mapChanges

136172-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value

137173holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))

138174holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes

175+

139176 where

140177 modify k Nothing items = Map.delete k items

141178 modify k (Just item) items = Map.insert k item items

@@ -145,6 +182,7 @@ holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)

145182holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))

146183holdMap = (current <$>) . holdMapDyn

147184

185+

148186increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)

149187increasingMerge xs = do

150188 e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])

@@ -167,34 +205,43 @@ modifyMerge xs = do

167205 where

168206 initial = Map.fromList $ zip [1..] xs

169207

208+

170209countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]

171210countMany = traverse (fmap current . count)

172211

173212countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]

174213countManyDyn = traverse count

175214

215+

176216-- Given a function which creates a sub-network (from a single event)

177217-- Create a plan which uses a switch to substitute it

178218switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)

179219switches numFrames f = do

180220 es <- events numFrames

181221 switch <$> hold never (makeEvents es)

222+

182223 where

183224 makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es

184225

226+

227+

185228-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)

186229-- the other, which we're only interested in time for running frames

187230subscribing :: Word -> Word -> [(String, TestCase)]

188231subscribing 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)

232+ [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n

233+ , testSub "fanMerge" $ return . fanMerge n

234+ , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n

235+ , testSub "fmapChain" $ return . fmapChain n

236+ , testSub "switchChain" $ switchChain n

237+ , testSub "switchPromptlyChain" $ switchPromptlyChain n

238+ , testSub "switchFactors" $ switchFactors n

239+ , testSub "coincidenceChain" $ return . coinChain n

196240 ]

197241

242+ where

243+ testSub :: (Eq a, Show a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)

244+ testSub name test = testE name (switches frames test)

198245

199246-- Set of benchmark to test specifically merging dynamic collections

200247-- a pattern which occurs frequently in reflex-dom collections

@@ -209,6 +256,11 @@ merging n =

209256 , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters

210257 , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters

211258 , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters

259+

260+

261+ -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse

262+ -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse

263+ -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse

212264 ]

213265

214266 where

@@ -218,15 +270,37 @@ merging n =

218270 counters :: TestPlan t m => m [Behavior t Int]

219271 counters = countMany =<< sparse

220272

273+

274+

275+fans :: Word -> [(String, TestCase)]

276+fans n =

277+ [ testE "fanMapChain" $ fanMergeChain n 10 <$> e

278+ , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e

279+

280+ , testE "fanMerge " $ fanMerge n <$> events n

281+

282+ , testE "fmapFanMerge " $ fmapFanMerge n <$> events n

283+ , testE "triggerMerge" $ leftmost <$> forM [1..n] (\i -> plan [(i, i)])

284+

285+ ]

286+ where

287+

288+ e :: TestPlan t m => m (Event t Word)

289+ e = events 100

290+

291+

292+

293+

221294dynamics :: Word -> [(String, TestCase)]

222295dynamics n =

223296 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

224297 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

225298 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

226− , testE "dense mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< dense

299+ , testE "dense mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< dense

227300 , testE "sparse mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< sparse

228301 , testE "mergeDyn" $ fmap updated $ mapDyn sum =<< mergeListDyn =<< sparse

229302 ] where

303+

230304 d :: TestPlan t m => m (Dynamic t Word)

231305 d = count =<< events 10

232306

@@ -245,20 +319,25 @@ firing n =

245319

246320 , testE "dense mergeTree" $ mergeTree 8 <$> dense

247321 , testE "sparse mergeTree" $ mergeTree 8 <$> sparse

248− , testE "runFrame" $ events n

322+

323+ -- Triggers test failure in Spider

324+ --, testE "runFrame" $ events n

325+

249326 , testB "sum counters" $ do

250327 counts <- counters

251328 return $ pull $ sum <$> traverse sample counts

252329

253− , testB "pullChain" $ pullChain n . current <$> (count =<< events 4)

330+ , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4)

254331 , 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− ]

332+ es <- events 4

333+ e <- plan [(0, ())]

334+

335+ b <- hold (constant 0) $

336+ pushAlways (const $ fmapChain n <$> hold 0 es) e

337+

260338 return (join b)

261339 , testB "counters/pullTree" $ mergeTree 8 <$> counters

340+

262341 ]

263342 where

264343 e :: TestPlan t m => m (Event t Word)

@@ -271,3 +350,7 @@ firing n =

271350 counters :: TestPlan t m => m [Behavior t Int]

272351 counters = countMany =<< sparse

273352

353+

354+

355+

356+

test/Reflex/Plan/Pure.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}

3+module Reflex.Plan.Pure where

5+import Reflex

6+import Reflex.Pure

7+import Reflex.TestPlan

9+import Control.Monad.Fix

10+import Control.Monad.State

11+import Data.IntMap (IntMap)

12+import qualified Data.IntMap as IntMap

13+import Data.IntSet (IntSet)

14+import qualified Data.IntSet as IntSet

15+

16+import Data.Monoid

17+import Data.Bifunctor

18+import Data.Maybe

19+import Prelude

20+

21+

22+mapToPureEvent :: IntMap a -> Event (Pure Int) a

23+mapToPureEvent m = Event $ flip IntMap.lookup m

24+

25+type TimeM = (->) Int

26+newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix)

27+

28+liftPlan :: TimeM a -> PurePlan a

29+liftPlan = PurePlan . lift

30+

31+instance MonadHold (Pure Int) PurePlan where

32+ hold initial = liftPlan . hold initial

33+

34+instance MonadSample (Pure Int) PurePlan where

35+ sample = liftPlan . sample

36+

37+

38+instance TestPlan (Pure Int) PurePlan where

39+ plan occs = do

40+ PurePlan . modify $ IntSet.union (IntMap.keysSet m)

41+ return $ mapToPureEvent m

42+ where m = IntMap.fromList (first fromIntegral <$> occs)

43+

44+runPure :: PurePlan a -> (a, IntSet)

45+runPure (PurePlan p) = runStateT p mempty $ 0

46+

47+relavantTimes :: IntSet -> IntSet

48+relavantTimes occs = IntSet.fromList [0..l + 1]

49+ where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

50+

51+testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

52+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)

53+

54+testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

55+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)

56+

57+

58+

59+

60+

61+

test/Reflex/Plan/Reflex.hs+5−4

@@ -24,6 +24,7 @@ import Reflex.TestPlan

2424

2525import Control.Applicative

2626import Control.Monad

27+import Control.Monad.Identity

2728import Control.Monad.State.Strict

2829

2930import Data.Dependent.Sum (DSum (..))

@@ -71,8 +72,8 @@ instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => T

7172 makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])

7273

7374

74−firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t)))

75−firingTrigger (Firing ref a) = fmap (:=> a) <$> readRef ref

75+firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))

76+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref

7677

7778runPlan :: (MonadReflexHost t m, MonadIORef m) => Plan t a -> m (a, Schedule t)

7879runPlan (Plan p) = runHostFrame $ runStateT p mempty

@@ -97,8 +98,8 @@ readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResu

9798

9899triggerFrame :: (MonadReflexHost t m, MonadIORef m) => ReadPhase m a -> Int -> [Firing t] -> m a

99100triggerFrame readResult _ occs = do

100− triggers <- {-# SCC "catMaybes/traverse" #-} catMaybes <$> traverse firingTrigger occs

101− {-# SCC fireEventsAndRead #-} fireEventsAndRead triggers readResult

101+ triggers <- catMaybes <$> traverse firingTrigger occs

102+ fireEventsAndRead triggers readResult

102103

103104

104105readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)

test/Reflex/Test.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

3+module Reflex.Test

4+ ( testAgreement

5+ , compareResult

6+ , runTests

8+ , module Reflex.TestPlan

10+ ) where

11+

12+import Reflex.Spider

13+

14+import Reflex.TestPlan

15+

16+import Reflex.Plan.Pure

17+import Reflex.Plan.Reflex

18+

19+import Control.Monad

20+import Data.Monoid

21+

22+import Data.IntMap (IntMap)

23+

24+import Data.Foldable

25+import System.Exit

26+

27+import Prelude

28+

29+

30+testAgreement :: TestCase -> IO Bool

31+testAgreement (TestE p) = do

32+ spider <- runSpiderHost $ runTestE p

33+ let results = [("spider", spider)]

34+

35+ compareResult results (testEvent $ runPure p)

36+

37+testAgreement (TestB p) = do

38+ spider <- runSpiderHost $ runTestB p

39+ let results = [("spider", spider)]

40+

41+ compareResult results (testBehavior $ runPure p)

42+

43+

44+compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool

45+compareResult results expected = fmap and $ forM results $ \(name, r) -> do

46+

47+ when (r /= expected) $ do

48+ putStrLn ("Got: " ++ show (name, r))

49+ putStrLn ("Expected: " ++ show expected)

50+ return (r == expected)

51+

52+

53+runTests :: [(String, TestCase)] -> IO ()

54+runTests testCases = do

55+ results <- forM testCases $ \(name, test) -> do

56+ putStrLn $ "Test: " <> name

57+ testAgreement test

58+ exitWith $ if and results

59+ then ExitSuccess

60+ else ExitFailure 1

61+

test/Reflex/Test/Micro.hsnew file+298

@@ -0,0 +1,298 @@

1+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

3+module Reflex.Test.Micro (testCases) where

5+import Reflex

6+import Reflex.TestPlan

8+import Control.Monad

9+import Control.Applicative

10+import Data.Char

11+import Data.Monoid

12+import Data.Functor.Misc

13+

14+import Data.Foldable

15+

16+import Data.Map (Map)

17+import qualified Data.Map as Map

18+

19+import Prelude

20+

21+testCases :: [(String, TestCase)]

22+testCases =

23+ [ testB "hold" $ hold "0" =<< events1

24+ , testB "count" $ do

25+ b <- current <$> (count =<< events2)

26+ return $ (+ (0::Int)) <$> b

27+

28+ , testB "pull-1" $ do

29+ b <- hold "0" =<< events1

30+ return (id <$> id <$> b)

31+

32+

33+ , testB "pull-2" $ do

34+ b1 <- behavior1

35+ return (id <$> pull $ liftA2 (<>) (sample b1) (sample b1))

36+

37+ , testB "pull-3" $ do

38+ b1 <- behavior1

39+ b2 <- behavior2

40+ return (id <$> pull $ liftA2 (<>) (sample b1) (sample b2))

41+

42+ , testB "pull-4" $ do

43+ es <- planList ["a", "b", "c"]

44+ e <- plan [(0, ())]

45+

46+ b <- hold (constant "") $

47+ pushAlways (const $ hold "z" es) e

48+

49+ return (join b)

50+

51+ , testE "tag-1" $ do

52+ b1 <- behavior1

53+ e <- events2

54+ return (tag b1 e)

55+

56+ , testE "tag-2" $ do

57+ b1 <- behavior1

58+ e <- events2

59+ return (tag (map toUpper <$> b1) e)

60+

61+ , testE "attach-1" $ do

62+ b1 <- behavior1

63+ e <- events2

64+ return (attachWith (++) (map toUpper <$> b1) e)

65+

66+ , testE "leftmost" $ liftA2 leftmost2 events1 events2

67+

68+ , testE "appendEvents-1" $ liftA2 appendEvents events1 events2

69+ , testE "appendEvents-2" $ liftA2 appendEvents events3 events2

70+

71+

72+ , testE "merge-1" $ do

73+ e <- events1

74+ return $ leftmost ["x" <$ e, "y" <$ e]

75+

76+ , testE "merge-2" $ do

77+ e <- events1

78+ let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]

79+

80+ let ee = flip pushAlways e $ const $ return m

81+ return $ coincidence ee

82+

83+ , testE "onceE-1" $ do

84+ e <- events1

85+ onceE $ leftmost [e, e]

86+

87+

88+ , testE "onceE-2" $ do

89+ e <- events1

90+ b <- hold never (e <$ e)

91+ onceE $ switch b

92+

93+

94+ , testE "switch-1" $ do

95+ e <- events1

96+ b <- hold never (e <$ e)

97+ return $ switch b

98+

99+ , testE "switch-2" $ do

100+ e <- events1

101+ return $ coincidence $ flip pushAlways e $ const $ do

102+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)

103+

104+ , testE "switch-3" $ do

105+ e <- events1

106+ return $ coincidence $ flip pushAlways e $ const $ do

107+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never

108+

109+ , testE "switch-4" $ do

110+ e <- events1

111+ switch <$> hold (deep e) (e <$ e)

112+

113+

114+ , testE "switch-5" $ do

115+ e <- events1

116+ return $ coincidence $ flip pushAlways e $ const $

117+ return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]

118+

119+ , testE "switch-6" $ do

120+ e <- events1

121+ return $ coincidence $ flip pushAlways e $ const $ do

122+ switch <$> hold ("x" <$ e) (e <$ e)

123+

124+

125+ , testE "switchPromptly-1" $ do

126+ e <- events1

127+ let e' = e <$ e

128+ switchPromptly never $ e <$ e'

129+

130+ , testE "switchPromptly-2" $ do

131+ e <- events1

132+ switchPromptly never $ deep (e <$ e)

133+

134+ , testE "switchPromptly-3" $ do

135+ e <- events1

136+ switchPromptly never $ (e <$ deep e)

137+

138+ , testE "switchPromptly-4" $ do

139+ e <- events1

140+ switchPromptly never $ (deep e <$ e)

141+

142+ , testE "switch-5" $ do

143+ e <- events1

144+ switch <$> hold never (deep e <$ e)

145+

146+ , testE "switchPromptly-5" $ do

147+ e <- events1

148+ switchPromptly never $ flip push e $

149+ const (Just <$> onceE e)

150+

151+ , testE "switchPromptly-6" $ do

152+ e <- events1

153+ switchPromptly never $ flip pushAlways e $

154+ const (switchPromptly e never)

155+

156+ , testE "coincidence-1" $ do

157+ e <- events1

158+ return $ coincidence $ flip pushAlways e $

159+ const $ return (id <$> e)

160+

161+ , testE "coincidence-2" $ do

162+ e <- events1

163+ return $ coincidence $ flip pushAlways e $

164+ const $ return (deep e)

165+

166+ , testE "coincidence-3" $ do

167+ e <- events1

168+ return $ coincidence $ flip pushAlways e $

169+ const $ return (coincidence (e <$ e))

170+

171+ , testE "coincidence-4" $ do

172+ e <- events1

173+ return $ coincidence $ flip pushAlways e $

174+ const (onceE e)

175+

176+ , testE "coincidence-5" $ do

177+ e <- events1

178+ return $ coincidence $ flip pushAlways e $ const $ do

179+ let e' = deep e

180+ return (coincidence (e' <$ e'))

181+

182+ , testE "coincidence-6" $ do

183+ e <- events1

184+ return $ coincidence $ flip pushAlways e $ const $ do

185+ let e' = coincidence (e <$ e)

186+ return $ deep e'

187+

188+ , testE "coincidence-7" $ do

189+ e <- events1

190+ return $ coincidence (deep e <$ e)

191+

192+ , testB "holdWhileFiring" $ do

193+ e <- events1

194+ eo <- onceE e

195+ bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo

196+ return $ pull $ sample =<< sample bb

197+

198+ , testE "joinDyn" $ do

199+ e <- events1

200+ bb <- hold "b" e

201+ bd <- hold never . fmap (const e) =<< onceE e

202+

203+ eOuter <- pushAlways sample . fmap (const bb) <$> onceE e

204+ let eInner = switch bd

205+ return $ leftmost [eOuter, eInner]

206+

207+ , testB "foldDyn" $ do

208+ d <- foldDyn (++) "0" =<< events1

209+ return (current d)

210+

211+ , testB "mapDyn" $ do

212+ d <- foldDyn (++) "0" =<< events1

213+ current <$> mapDyn (map toUpper) d

214+

215+ , testB "combineDyn" $ do

216+ d1 <- foldDyn (++) "0" =<< events1

217+ d2 <- mapDyn (map toUpper) =<< foldDyn (++) "0" =<< events2

218+

219+ current <$> combineDyn (<>) d1 d2

220+ , testE "fan-1" $ do

221+ e <- fmap toMap <$> events1

222+ let es = select (fanMap e) . Const2 <$> values

223+

224+ return (mergeList es)

225+

226+ , testE "fan-2" $ do

227+ e <- fmap toMap <$> events3

228+ let es = select (fanMap e) . Const2 <$> values

229+

230+ return (mergeList es)

231+

232+ , testE "fan-3" $ do

233+ f <- fanMap <$> fmap toMap <$> events3

234+ return $ select f (Const2 'c')

235+

236+ , testE "fan-4" $ do

237+ e <- fmap toMap <$> events1

238+ return $ toUpper <$> select (fanMap e) (Const2 'a')

239+

240+ , testE "fan-5" $ do

241+ e <- fmap toMap <$> events2

242+ return $ toUpper <$> select (fanMap e) (Const2 'c')

243+

244+ , testE "fan-6" $ do

245+ f <- fanMap <$> fmap toMap <$> events1

246+ return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]

247+

248+ -- , testE "switchMerge-1" $ switchMergeMap mempty =<< increasing

249+

250+ -- , testE "switchMerge-2" $ do

251+ -- e <- eventsFrom 0

252+ -- switchMergeMap (Map.singleton 0 e) =<< increasing

253+

254+ -- , testE "switchMerge-3" $ do

255+ -- es <- eventsMany

256+ -- switchMergeMap es =<< increasing

257+

258+ -- , testE "switchMerge-4" $ do

259+ -- es <- eventsMany

260+ -- switchMergeMap es =<< decreasing

261+

262+ ] where

263+

264+ events1, events2, events3 :: TestPlan t m => m (Event t String)

265+ events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]

266+ events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]

267+

268+ events3 = liftA2 appendEvents events1 events2

269+

270+ eventsFrom :: TestPlan t m => Word -> m (Event t Int)

271+ eventsFrom n = plan $ zip [n..8] [1..8]

272+

273+ increasing :: TestPlan t m => m (Event t (Map Int (Event t Int)))

274+ increasing = do

275+ es <- mapM eventsFrom [1..8]

276+ planList $ zipWith Map.singleton [1..8] es

277+

278+ decreasing :: TestPlan t m => m (Event t (Map Int (Event t Int)))

279+ decreasing = planList $ zipWith Map.singleton [1..8] (repeat never)

280+

281+ eventsMany :: TestPlan t m => m (Map Int (Event t Int))

282+ eventsMany = do

283+ es <- mapM eventsFrom [8,7..1]

284+ return $ Map.fromList $ zip [1..8] es

285+

286+

287+ values = "abcde"

288+ toMap str = Map.fromList $ map (\c -> (c, c)) str

289+

290+

291+ behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)

292+ behavior1 = hold "1" =<< events1

293+ behavior2 = hold "2" =<< events2

294+

295+ deep e = leftmost [e, e]

296+ leftmost2 e1 e2 = leftmost [e1, e2]

297+

298+

test/Reflex/Test/RunAll.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

3+module Main (main) where

5+import Reflex.Test

7+import qualified Reflex.Bench.Focused as Focused

8+import qualified Reflex.Test.Micro as Micro

9+import Data.Bifunctor

10+import Data.List

11+

12+import System.Exit

13+import System.Environment

14+

15+import Prelude

16+

17+matchPrefixes :: [String] -> (String -> Bool)

18+matchPrefixes [] = const True

19+matchPrefixes args = \name -> any (`isPrefixOf` name) args

20+

21+

22+main :: IO ()

23+main = do

24+ args <- getArgs

25+

26+ case args of

27+ ["--list"] -> mapM_ putStrLn (fst <$> allTests) >> exitWith (ExitFailure 1)

28+ _ -> case filter (matchPrefixes args . fst) allTests of

29+ [] -> putStrLn "filter did not match any tests" >> exitWith (ExitFailure 1)

30+ tests -> runTests tests

31+

32+ where

33+ allTests = concat

34+ [ makeGroup "micro" Micro.testCases

35+ , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)

36+ , makeGroup "firing 1000" (Focused.firing 1000)

37+ , makeGroup "merge 100" (Focused.merging 100)

38+ , makeGroup "fan 50" (Focused.fans 50)

39+ ]

40+

41+ makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests

42+

43+

test/Reflex/TestPlan.hs−3

@@ -13,9 +13,6 @@ module Reflex.TestPlan

1313import Reflex.Class

1414import Control.Monad.Fix

1515

16−import qualified Data.IntMap as IntMap

17−import Data.IntMap

18−

1916import Prelude

2017

2118class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where