4a6ee12 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Update benchmarks and add tests

4a6ee12Oliver Batchelor11 years ago

bench/Main.hs+7−6

compare with develop

unifiedsplit

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

7import Data.Functor.Misc

8import Control.Monad.Primitive

9import Control.Monad.IO.Class

10+import Control.Monad.Identity

10import Data.Dependent.Sum

11import Data.Dependent.Sum

11import Control.Concurrent.STM

12import Control.Concurrent.STM

12import Control.Applicative

13import Control.Applicative

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

73 (newEventWithTriggerRef >>= subscribePair)

74 (newEventWithTriggerRef >>= subscribePair)

74 (\(subd, trigger) -> do

75 (\(subd, trigger) -> do

75 Just key <- liftIO $ readIORef trigger

76 Just key <- liftIO $ readIORef trigger

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

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

77 , withSetupWHNF "fireEventsAndRead(head/merge1)"

78 , withSetupWHNF "fireEventsAndRead(head/merge1)"

78 (setupMerge 1 >>= subscribePair)

79 (setupMerge 1 >>= subscribePair)

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

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

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

87 (setupMerge 100 >>= subscribePair)

88 (setupMerge 100 >>= subscribePair)

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

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

89 Just key <- liftIO $ readIORef t

90 Just key <- liftIO $ readIORef t

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

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

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

92 , 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

93 ]

94 ]

95setupMerge :: Int

96setupMerge :: Int

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

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

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

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

98setupMerge num = do

99setupMerge num = do

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

100 (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]

101 pure (merge m, triggers)

102 pure (merge m, triggers)

102

103

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

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

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

107 -> SpiderHost (Maybe b)

108 -> SpiderHost (Maybe b)

108fireAndRead trigger val subd = do

109fireAndRead trigger val subd = do

109 Just key <- liftIO $ readIORef trigger

110 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

46 other-extensions: TemplateHaskell

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

49+

49−test-suite cross-impl

50+test-suite all

50 type: exitcode-stdio-1.0

51 type: exitcode-stdio-1.0

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

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

52− other-modules:

53− Reflex.Pure

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

53+ ghc-options: -O2 -Wall

55 hs-source-dirs: test

54 hs-source-dirs: test

56 build-depends:

55 build-depends:

57 base,

56 base,

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

60 mtl,

59 mtl,

61 containers,

60 containers,

62 dependent-map,

61 dependent-map,

62+ dependent-sum,

63− MemoTrie == 0.6.*

63+ MemoTrie == 0.6.*,

64+ split

65+

65benchmark spider-bench

67benchmark spider-bench

66 type: exitcode-stdio-1.0

68 type: exitcode-stdio-1.0

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

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

8import Control.Monad.Fix

9import Control.Monad

10+import Control.Monad.Identity

10import Control.Applicative

11import Control.Applicative

11import Data.Foldable

12import Data.Foldable

12import Data.Traversable

13import Data.Traversable

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

14import Data.Maybe

15import Data.Maybe

15import Data.Map (Map)

16import Data.Map (Map)

16import qualified Data.Map as Map

17import qualified Data.Map as Map

18+import qualified Data.Dependent.Map as DMap

19+

20+import Data.Functor.Misc

18import Data.Tuple

22import Data.Tuple

19import Data.List

23import Data.List

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

22import Prelude

26import Prelude

28+

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

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

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

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

26 | otherwise = mergeTree n subTrees

31 | otherwise = mergeTree n subTrees

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

39 merges = chunksOf n dyns

44 merges = chunksOf n dyns

40 sumDyns ds = mergeListDyn ds >>= mapDyn sum

45 sumDyns ds = mergeListDyn ds >>= mapDyn sum

47+

48+

42-- N events all firing for N frames

49-- N events all firing for N frames

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

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

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

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

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

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

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

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

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

60+

61+

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

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

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

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

55never' = plan []

64never' = plan []

66+

57-- Event which fires once on first frame

67-- Event which fires once on first frame

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

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

59event = plan [(1, 0)]

69event = plan [(1, 0)]

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

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

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

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

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

75+

65-- N events all originating from one event

76-- N events all originating from one event

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

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

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

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

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+

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

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

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

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

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

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

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

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

102

74−fmapChain :: Reflex t => Word -> Event t Word -> (Event t Word)

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

75−fmapChain 0 e = e

104+iter _ 0 a = a

76−fmapChain n e = fmapChain (n - 1) (fmap (+1) e)

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

113

78mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

114mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

79−mapDynChain 0 d = return d

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

80−mapDynChain n d = mapDynChain (n - 1) =<< mapDyn (+1) d

116

82joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

117joinDynChain :: (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)

119

86combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

120combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

87−combineDynChain 0 d = return d

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

88−combineDynChain n d = combineDynChain (n - 1) =<< combineDyn (+) d d

122

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

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

91pingPong e1 e2 = do

124pingPong e1 e2 = do

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

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

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

101 switchFactors (i - 1) (switch b)

134 switchFactors (i - 1) (switch b)

102

135

136+

103switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)

137switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)

104−switchChain 0 e = return e

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

105−switchChain i e = switchChain (i - 1) =<< pingPong e ((+1) <$> e)

139+

106

140

107switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)

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

110

143

111switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)

144switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)

112−switchPromptlyChain 0 e = return e

145+switchPromptlyChain = iterM $ \e ->

113−switchPromptlyChain i e = do

114− d <- holdDyn e (e <$ e)

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

115− switchPromptlyChain (i - 1) (switchPromptlyDyn d)

147+

116

148

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

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

118−coinChain 0 e = e

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

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

151+

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

153+fanMergeChain width = iter $ fanMerge width

120

154

121−pullChain :: Reflex t => Word -> Behavior t Word -> Behavior t Word

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

122−pullChain 0 b = b

156+fmapFanMergeChain width = iter $ fmapFanMerge width

123−pullChain n b = pullChain (n - 1) $ (+1) <$> b

124

157

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

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

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

159data 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)))

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

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

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

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

131

164

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+

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

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

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

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

134 where joinMap m = traverse sample =<< sample m

170 where joinMap m = traverse sample =<< sample m

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

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

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

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

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

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

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

175+

139 where

176 where

140 modify k Nothing items = Map.delete k items

177 modify k Nothing items = Map.delete k items

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

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

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

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

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

146holdMap = (current <$>) . holdMapDyn

183holdMap = (current <$>) . holdMapDyn

147

184

185+

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

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

149increasingMerge xs = do

187increasingMerge xs = do

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

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

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

167 where

205 where

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

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

169

207

208+

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

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

171countMany = traverse (fmap current . count)

210countMany = traverse (fmap current . count)

172

211

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

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

174countManyDyn = traverse count

213countManyDyn = traverse count

175

214

215+

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

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

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

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

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

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

179switches numFrames f = do

219switches numFrames f = do

180 es <- events numFrames

220 es <- events numFrames

181 switch <$> hold never (makeEvents es)

221 switch <$> hold never (makeEvents es)

222+

182 where

223 where

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

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

184

225

226+

227+

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

228-- 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

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

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

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

188subscribing n frames =

231subscribing n frames =

189− [ testE "fmapFan merge" $ switches frames (return . mergeList . fmapFan n)

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

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

190− , testE "fmapFan/mergeTree" $ switches frames (return . mergeTree 8 . fmapFan n)

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

191− , testE "fmapChain" $ switches frames (return . fmapChain n)

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

192− , testE "switchChain" $ switches frames (switchChain n)

236+ , testSub "switchChain" $ switchChain n

193− , testE "switchPromptlyChain" $ switches frames (switchPromptlyChain n)

237+ , testSub "switchPromptlyChain" $ switchPromptlyChain n

194− , testE "switchFactors" $ switches frames (switchFactors n)

238+ , testSub "switchFactors" $ switchFactors n

195− , testE "coincidenceChain" $ switches frames (return . coinChain n)

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

196 ]

240 ]

197

241

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)

198

245

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

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

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

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

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

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

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

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

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

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

258 , 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

212 ]

264 ]

213

265

214 where

266 where

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

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

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

219 counters = countMany =<< sparse

271 counters = countMany =<< sparse

220

272

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+

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

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

222dynamics n =

295dynamics n =

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

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

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

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

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

298 , 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

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

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

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

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

229 ] where

302 ] where

303+

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

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

231 d = count =<< events 10

305 d = count =<< events 10

232

306

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

245

319

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

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

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

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

322+

323+ -- Triggers test failure in Spider

248− , testE "runFrame" $ events n

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

325+

249 , testB "sum counters" $ do

326 , testB "sum counters" $ do

250 counts <- counters

327 counts <- counters

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

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

252

329

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

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

254 , testB "pullChain2" $ do

331 , testB "pullChain2" $ do

255− e' <- events 4

332+ es <- events 4

256− b <- hold (constant 0) $ leftmost

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

257− [ constant 0 <$ ffilter (==4) e'

334+

335+ b <- hold (constant 0) $

258− , pushAlways (const $ pullChain n <$> hold 0 e') e'

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

259− ]

337+

260 return (join b)

338 return (join b)

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

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

340+

262 ]

341 ]

263 where

342 where

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

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

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

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

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

272 counters = countMany =<< sparse

351 counters = countMany =<< sparse

273

352

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

25import Control.Applicative

26import Control.Monad

27+import Control.Monad.Identity

27import Control.Monad.State.Strict

28import Control.Monad.State.Strict

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

99triggerFrame readResult _ occs = do

100triggerFrame readResult _ occs = do

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

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

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

102+ fireEventsAndRead triggers readResult

102

103

104

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

105readEvent' :: 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

13import Reflex.Class

14import Control.Monad.Fix

16−import qualified Data.IntMap as IntMap

17−import Data.IntMap

18−

19import Prelude

16import Prelude

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

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