8fc31eb · reflex · git.iko.soy

git.iko.soy/reflex

Add tests for BuildDynamic

commit8fc31ebdea8f951103a0a920dc2a6969a205b5d4 authorOliver Batchelor <saulzar@gmail.com> dateFri 3 Aug 2018, 01:34 (8 years ago) parent8031150

5 files changed+71−147

compare with develop

unifiedsplit

reflex.cabal−17 test/BuildDynamic.hs−121 test/Reflex/Test/CrossImpl.hs+3 test/Reflex/Test/Micro.hs+64−3 test/semantics.hs+4−6

reflex.cabal−17

@@ -213,23 +213,6 @@ test-suite RequesterT

213213 , ref-tf

214214 buildable: False

215215

216−

217−test-suite BuildDynamic

218− type: exitcode-stdio-1.0

219− main-is: BuildDynamic.hs

220− hs-source-dirs: test

221− build-depends: base

222− , reflex

223− , dependent-map

224−

225− , dependent-sum

226− , these

227− , ref-tf

228− , lens

229−

230− other-modules: Test.Run

231−

232−

233216test-suite QueryT

234217 type: exitcode-stdio-1.0

235218 main-is: QueryT.hs

test/BuildDynamic.hsdeleted−121

@@ -1,121 +0,0 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE RankNTypes #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE RecursiveDo #-}

6−

7−module Main where

8−

9−import Control.Lens

10−import Control.Monad

11−import Control.Monad.Fix

12−import qualified Data.Dependent.Map as DMap

13−import Data.Dependent.Sum

14−import Data.These

15−import Data.Monoid

16−

17−import Reflex

18−import Test.Run

19−

20−pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)

21−pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))

22−

23−foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)

24−foldedDyn f d = fmap join $ flip buildDynamic never $ do

25− a <- sample (current d)

26− foldDyn f a (updated d)

27−

28−scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])

29−scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure

30−

31−scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])

32−scanInnerDyns d = do

33− scans <- scannedDyn d

34− return (join (fmap distributeListOverDynPure scans))

35−

36−

37−main :: IO ()

38−main = do

39−

40− r <- last <$> runAppB testInnerHoldsE (Just <$> [1..4])

41− -- [[[0,1,2],[1,2],[2]]]]

42−

43− -- r <- runAppB testScan counter

44−

45− -- r <- runAppB testStrictness (fmap Just [1..9])

46−

47−

48− print r

49− return ()

50−

51− where

52− counter = fmap Just [1..9] <> [Nothing]

53− eithers = fmap Just [ Left 1, Left 2, Right 3, Left 4, Left 5, Right 6, Right 7, Right 8, Left 9 ] <> [Nothing]

54−

55−testIdentity :: (Reflex t, MonadHold t m, MonadFix m)

56− => Event t Int -> m (Behavior t Int)

57−testIdentity e = do

58− d <- holdDyn 0 e

59− d' <- pushDyn return d

60− d'' <- pushDyn return d'

61−

62− return (current d'')

63−

64−testStrictness :: (Reflex t, MonadHold t m, MonadFix m)

65− => Event t Int -> m (Behavior t Int)

66−testStrictness e = do

67−

68− rec

69− d'' <- pushDyn return d'

70− d' <- pushDyn return d

71− d <- holdDyn 0 e

72−

73− return (current d'')

74−

75−

76−testScan :: (Reflex t, MonadHold t m, MonadFix m)

77− => Event t Int -> m (Behavior t [Int])

78−testScan e = do

79− d <- holdDyn 0 e

80− scan <- scannedDyn d

81− return (current scan)

82−

83−testFactor :: (Reflex t, MonadHold t m, MonadFix m)

84− => Event t (Either Int Int) -> m (Behavior t (Either Int Int))

85−testFactor e = do

86− d <- holdDyn (Left 0) e

87−

88− eithers <- eitherDyn d

89− return $ current (join (fmap unFactor eithers))

90−

91− where

92− unFactor = either (fmap Left) (fmap Right)

93−

94−testInnerHolds :: (Reflex t, MonadHold t m, MonadFix m)

95− => Event t Int -> m (Behavior t [Int])

96−testInnerHolds e = do

97− d <- holdDyn 0 e

98−

99− d' <- pushDyn (\a -> foldDyn (:) [a] (updated d)) d

100− return $ current (join d')

101−

102−testInnerHoldsE :: forall t m. (Reflex t, MonadHold t m, MonadFix m)

103− => Event t Int -> m (Behavior t [[Int]])

104−testInnerHoldsE e = do

105− initial <- f 0

106− d <- foldDyn snoc [initial] updates

107− return $ current (join (fmap distributeListOverDynPure d))

108− where

109− f :: forall n. (MonadHold t n, MonadFix n) => Int -> n (Dynamic t [Int])

110− f a = foldDyn snoc [a] e

111− updates = pushAlways f e

112−

113− snoc x xs = xs ++ [x]

114−

115−testInnerHolds1 :: (Reflex t, MonadHold t m, MonadFix m)

116− => Event t Int -> m (Behavior t [[Int]])

117−testInnerHolds1 e = do

118− d <- fmap pure <$> holdDyn 0 e

119−

120− d' <- pushDyn (\a -> foldDyn (flip mappend) a (updated d)) d

121− current <$> scanInnerDyns d'

test/Reflex/Test/CrossImpl.hs+3

@@ -230,6 +230,9 @@ testCases =

230230 rec result <- holdUniqDyn d

231231 d <- holdDyn (0 :: Int) e

232232 return (current result, updated result)

233+

234+

235+

233236 {-

234237 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

235238 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

test/Reflex/Test/Micro.hs+64−3

@@ -3,6 +3,7 @@

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE RankNTypes #-}

89{-# LANGUAGE RecursiveDo #-}

@@ -23,6 +24,24 @@ import Data.Monoid

2324

2425import Prelude

2526

27+pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)

28+pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))

29+

30+foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)

31+foldedDyn f d = fmap join $ flip buildDynamic never $ do

32+ a <- sample (current d)

33+ foldDyn f a (updated d)

34+

35+scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])

36+scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure

37+

38+scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])

39+scanInnerDyns d = do

40+ scans <- scannedDyn d

41+ return (join (fmap distributeListOverDynPure scans))

42+

43+

44+

2645{-# ANN testCases "HLint: ignore Functor law" #-}

2746testCases :: [(String, TestCase)]

2847testCases =

@@ -201,6 +220,14 @@ testCases =

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

202221 return $ pull $ sample =<< sample bb

203222

223+

224+ , testB "foldDynWhileFiring" $ do

225+ e <- events1

226+ d <- foldDyn (:) [] $

227+ pushAlways (\a -> foldDyn (:) [a] e) e

228+

229+ return $ current (join (fmap distributeListOverDynPure d))

230+

204231 , testE "joinDyn" $ do

205232 e <- events1

206233 bb <- hold "b" e

@@ -223,6 +250,38 @@ testCases =

223250 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2

224251

225252 return $ current $ zipDynWith (<>) d1 d2

253+

254+ , testB "buildDynamicStrictness" $ do

255+ rec

256+ d'' <- pushDyn return d'

257+ d' <- pushDyn return d

258+ d <- holdDyn "0" =<< events1

259+

260+ _ <- sample (current d'')

261+ return (current d'')

262+

263+ , testB "factorDyn" $ do

264+ d <- holdDyn (Left "a") =<< eithers

265+

266+ eithers <- eitherDyn d

267+ let unFactor = either id id

268+ return $ current (join (fmap unFactor eithers))

269+

270+ , testB "pushDynDeep" $ do

271+ e1 <- events1

272+ e2 <- events2

273+

274+ d1 <- holdDyn "d1" =<< events1

275+ d2 <- holdDyn "d2" =<< events2

276+

277+ d <- flip pushDyn d1 $ \a ->

278+ flip pushDyn d2 $ \b ->

279+ flip pushDyn d1 $ \c ->

280+ return (a <> b <> c)

281+

282+ d' <- pushDyn scanInnerDyns d >>= scanInnerDyns

283+ return $ current d'

284+

226285 , testE "fan-1" $ do

227286 e <- fmap toMap <$> events1

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

@@ -264,14 +323,18 @@ testCases =

264323 return $ void e

265324 lazyHold

266325

326+

267327 ] where

268328

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

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

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

272−

273332 events3 = liftA2 mappend events1 events2

274333

334+ eithers :: TestPlan t m => m (Event t (Either String String))

335+ eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]

336+

337+

275338 values = "abcde"

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

277340

@@ -281,5 +344,3 @@ testCases =

281344

282345 deep e = leftmost [e, e]

283346 leftmost2 e1 e2 = leftmost [e1, e2]

284−

285−

test/semantics.hs+4−6

@@ -38,12 +38,10 @@ main = do

3838 where

3939 allTests = concat

4040 [ makeGroup "micro" Micro.testCases

41− , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)

42− , makeGroup "firing 1000" (Focused.firing 1000)

43− , makeGroup "merge 100" (Focused.merging 100)

44− , makeGroup "fan 50" (Focused.fans 50)

41+ -- , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)

42+ -- , makeGroup "firing 1000" (Focused.firing 1000)

43+ -- , makeGroup "merge 100" (Focused.merging 100)

44+ -- , makeGroup "fan 50" (Focused.fans 50)

4545 ]

4646

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

48−

49−