git.iko.soy/streamly
on d462530 help sign in
streamly/test/Main.hs
1150 lines 48 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE ScopedTypeVariables #-}
6module Main (main) where
8import Control.Concurrent (threadDelay)
9import Control.Exception (Exception, try, ErrorCall(..), catch, throw)
10import Control.Monad (void)
11import Control.Monad.Catch (throwM, MonadThrow)
12import Control.Monad.Error.Class (throwError, MonadError)
13import Control.Monad.IO.Class (MonadIO(liftIO))
14import Control.Monad.State (MonadState, get, modify, runStateT, StateT)
15import Control.Monad.Trans.Except (runExceptT, ExceptT)
16import Data.Foldable (forM_, fold)
17import Data.List (sort)
18import System.Mem (performMajorGC)
20import Data.IORef
21import Test.Hspec as H
23import Streamly
24import Streamly.Prelude ((.:), nil)
25import qualified Streamly.Prelude as S
27singleton :: IsStream t => a -> t m a
28singleton a = a .: nil
30toListSerial :: SerialT IO a -> IO [a]
31toListSerial = S.toList . serially
33toListInterleaved :: WSerialT IO a -> IO [a]
34toListInterleaved = S.toList . wSerially
36toListAsync :: AsyncT IO a -> IO [a]
37toListAsync = S.toList . asyncly
39toListParallel :: WAsyncT IO a -> IO [a]
40toListParallel = S.toList . wAsyncly
42main :: IO ()
43main = hspec $ do
44 parallelTests
46 describe "restricts concurrency and cleans up extra tasks" $ do
47 it "take 1 asyncly" $ checkCleanup 2 asyncly (S.take 1)
48 it "take 1 wAsyncly" $ checkCleanup 2 wAsyncly (S.take 1)
49 it "take 1 aheadly" $ checkCleanup 2 aheadly (S.take 1)
51 it "takeWhile (< 0) asyncly" $ checkCleanup 2 asyncly (S.takeWhile (< 0))
52 it "takeWhile (< 0) wAsyncly" $ checkCleanup 2 wAsyncly (S.takeWhile (< 0))
53 it "takeWhile (< 0) aheadly" $ checkCleanup 2 aheadly (S.takeWhile (< 0))
55#ifdef DEVBUILD
56 let timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int
57 timed x = S.yieldM (threadDelay (x * 100000)) >> return x
59 -- These are not run parallely because the timing gets affected
60 -- unpredictably when other tests are running on the same machine.
61 --
62 -- Also, they fail intermittently due to scheduling delays, so not run on
63 -- CI machines.
64 describe "Nested parallel and serial compositions" $ do
65 let t = timed
66 p = wAsyncly
67 s = serially
68 {-
69 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
70 -- because of parallelism of [8,0] and [8,0].
71 it "Nest <|>, <>, <|> (1)" $
72 let t = timed
73 in toListSerial (
74 ((t 8 <|> t 4) <> (t 2 <|> t 0))
75 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
76 `shouldReturn` ([4,4,8,8,0,0,2,2])
77 -}
78 it "Nest <|>, <>, <|> (2)" $
79 (S.toList . wAsyncly) (
80 s (p (t 4 <> t 8) <> p (t 1 <> t 2))
81 <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))
82 `shouldReturn` ([4,4,8,8,1,1,2,2])
83 -- FIXME: These two keep failing intermittently on Mac OS X
84 -- Need to examine and fix the tests.
85 {-
86 it "Nest <|>, <=>, <|> (1)" $
87 let t = timed
88 in toListSerial (
89 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
90 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
91 `shouldReturn` ([4,4,0,0,8,2,9,2])
92 it "Nest <|>, <=>, <|> (2)" $
93 let t = timed
94 in toListSerial (
95 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
96 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
97 `shouldReturn` ([4,4,1,1,8,2,9,2])
98 -}
99 it "Nest <|>, <|>, <|>" $
100 (S.toList . wAsyncly) (
101 ((t 4 <> t 8) <> (t 0 <> t 2))
102 <> ((t 4 <> t 8) <> (t 0 <> t 2)))
103 `shouldReturn` ([0,0,2,2,4,4,8,8])
105 -- parallely fails on CI machines, may need more difference in times of
106 -- the events, but that would make tests even slower.
107 it "take 1 parallely" $ checkCleanup 3 parallely (S.take 1)
108 it "takeWhile (< 0) parallely" $ checkCleanup 3 parallely (S.takeWhile (< 0))
110 testFoldOpsCleanup "head" S.head
111 testFoldOpsCleanup "null" S.null
112 testFoldOpsCleanup "elem" (S.elem 0)
113 testFoldOpsCleanup "notElem" (S.notElem 0)
114 testFoldOpsCleanup "elemIndex" (S.elemIndex 0)
115 -- S.lookup
116 testFoldOpsCleanup "notElem" (S.notElem 0)
117 testFoldOpsCleanup "find" (S.find (==0))
118 testFoldOpsCleanup "findIndex" (S.findIndex (==0))
119 testFoldOpsCleanup "all" (S.all (==1))
120 testFoldOpsCleanup "any" (S.any (==0))
121 testFoldOpsCleanup "and" (S.and . S.map (==1))
122 testFoldOpsCleanup "or" (S.or . S.map (==0))
123#endif
125 ---------------------------------------------------------------------------
126 -- Semigroup/Monoidal Composition strict ordering checks
127 ---------------------------------------------------------------------------
129 -- test both (<>) and mappend to make sure we are using correct instance
130 -- for Monoid that is using the right version of semigroup. Instance
131 -- deriving can cause us to pick wrong instances sometimes.
133 describe "WSerial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)
134 describe "WSerial interleaved mappend ordering check" $ interleaveCheck wSerially mappend
136 -- describe "WAsync interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)
137 -- describe "WAsync interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend
139 describe "Async (<>) time order check" $ parallelCheck asyncly (<>)
140 describe "Async mappend time order check" $ parallelCheck asyncly mappend
142 -- XXX this keeps failing intermittently, need to investigate
143 -- describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>)
144 -- describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend
146 describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)
147 describe "Parallel mappend time order check" $ parallelCheck parallely mappend
149checkCleanup :: IsStream t
150 => Int
151 -> (t IO Int -> SerialT IO Int)
152 -> (t IO Int -> t IO Int)
153 -> IO ()
154checkCleanup d t op = do
155 r <- newIORef (-1 :: Int)
156 S.drain . serially $ do
157 _ <- t $ op $ delay r 0 S.|: delay r 1 S.|: delay r 2 S.|: S.nil
158 return ()
159 performMajorGC
160 threadDelay 500000
161 res <- readIORef r
162 res `shouldBe` 0
163 where
164 delay ref i = threadDelay (i*d*100000) >> writeIORef ref i >> return i
166#ifdef DEVBUILD
167checkCleanupFold :: IsStream t
168 => (t IO Int -> SerialT IO Int)
169 -> (SerialT IO Int -> IO (Maybe Int))
170 -> IO ()
171checkCleanupFold t op = do
172 r <- newIORef (-1 :: Int)
173 _ <- op $ t $ delay r 0 S.|: delay r 1 S.|: delay r 2 S.|: S.nil
174 performMajorGC
175 threadDelay 500000
176 res <- readIORef r
177 res `shouldBe` 0
178 where
179 delay ref i = threadDelay (i*200000) >> writeIORef ref i >> return i
181testFoldOpsCleanup :: String -> (SerialT IO Int -> IO a) -> Spec
182testFoldOpsCleanup name f = do
183 let testOp op x = op x >> return Nothing
184 it (name <> " asyncly") $ checkCleanupFold asyncly (testOp f)
185 it (name <> " wAsyncly") $ checkCleanupFold wAsyncly (testOp f)
186 it (name <> " aheadly") $ checkCleanupFold aheadly (testOp f)
187 it (name <> " parallely") $ checkCleanupFold parallely (testOp f)
188#endif
190parallelTests :: SpecWith ()
191parallelTests = H.parallel $ do
192 describe "Runners" $ do
193 -- XXX move these to property tests
194 -- XXX use an IORef to store and check the side effects
195 it "simple serially" $
196 (S.drain . serially) (return (0 :: Int)) `shouldReturn` ()
197 it "simple serially with IO" $
198 (S.drain . serially) (S.yieldM $ putStrLn "hello") `shouldReturn` ()
200 describe "Empty" $ -- do
201 it "Monoid - mempty" $
202 toListSerial mempty `shouldReturn` ([] :: [Int])
203 -- it "Alternative - empty" $
204 -- (toListSerial empty) `shouldReturn` ([] :: [Int])
205 -- it "MonadPlus - mzero" $
206 -- (toListSerial mzero) `shouldReturn` ([] :: [Int])
208 ---------------------------------------------------------------------------
209 -- Functor
210 ---------------------------------------------------------------------------
212 describe "Functor (fmap)" $ do
213 -- XXX we should do these through property tests by using a
214 -- construction via list fold construction method.
215 it "fmap on composed (<>)" $
216 toListSerial (fmap (+1) (return 1 <> return 2))
217 `shouldReturn` ([2,3] :: [Int])
219 it "fmap on composed (<>)" $
220 sort <$> toListParallel (fmap (+1) (return 1 <> return 2))
221 `shouldReturn` ([2,3] :: [Int])
223 ---------------------------------------------------------------------------
224 -- Applicative
225 ---------------------------------------------------------------------------
227 describe "Applicative" $ do
228 -- XXX we should do these through property tests by using a
229 -- construction via list fold construction method.
230 it "Apply - serial composed first argument" $
231 toListSerial ((,) <$> (return 1 <> return 2) <*> return 3)
232 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
234 it "Apply - serial composed second argument" $
235 toListSerial ((,) <$> return 1 <*> (return 2 <> return 3))
236 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
238 it "Apply - parallel composed first argument" $
239 sort <$> toListParallel ((,) <$> (return 1 <> return 2) <*> return 3)
240 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
242 it "Apply - parallel composed second argument" $
243 sort <$> toListParallel ((,) <$> return 1 <*> (return 2 <> return 3))
244 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
246 ---------------------------------------------------------------------------
247 -- Monoidal Compositions, multiset equality checks
248 ---------------------------------------------------------------------------
250 describe "Serial Composition" $ compose serially mempty id
251 describe "Ahead Composition" $ compose aheadly mempty id
252 describe "WSerial Composition" $ compose wSerially mempty sort
253 describe "Async Composition" $ compose asyncly mempty sort
254 describe "WAsync Composition" $ compose wAsyncly mempty sort
255 describe "Parallel Composition" $ compose parallely mempty sort
256 describe "Semigroup Composition for ZipSerial" $ compose zipSerially mempty id
257 describe "Semigroup Composition for ZipAsync" $ compose zipAsyncly mempty id
258 -- XXX need to check alternative compositions as well
260 ---------------------------------------------------------------------------
261 -- TBD Monoidal composition combinations
262 ---------------------------------------------------------------------------
264 -- TBD need more such combinations to be tested.
265 describe "serial <> and serial <>" $
266 composeAndComposeSimple serially serially (repeat [1 .. 9])
267 describe "ahead <> and ahead <>" $
268 composeAndComposeSimple aheadly aheadly (repeat [1 .. 9])
269 describe "ahead <> and serial <>" $
270 composeAndComposeSimple aheadly serially (repeat [1 .. 9])
271 describe "serial <> and ahead <>" $
272 composeAndComposeSimple serially aheadly (repeat [1 .. 9])
274 describe "<> and <=>" $ composeAndComposeSimple
275 serially
276 wSerially
277 [ [1 .. 9]
278 , [1 .. 9]
279 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
280 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
281 ]
283 describe "<=> and <=>" $ composeAndComposeSimple
284 wSerially
285 wSerially
286 [ [1, 4, 2, 7, 3, 5, 8, 6, 9]
287 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
288 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
289 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
290 ]
292 describe "<=> and <>" $ composeAndComposeSimple
293 wSerially
294 serially
295 [ [1, 4, 2, 7, 3, 5, 8, 6, 9]
296 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
297 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
298 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
299 ]
301 ---------------------------------------------------------------------------
302 -- Monoidal composition recursion loops
303 ---------------------------------------------------------------------------
305 describe "Serial loops" $ loops serially id reverse
306 describe "Ahead loops" $ loops aheadly id reverse
307 describe "Async parallel loops" $ loops asyncly sort sort
308 describe "WAsync loops" $ loops wAsyncly sort sort
309 describe "parallel loops" $ loops parallely sort sort
311 ---------------------------------------------------------------------------
312 -- Bind and monoidal composition combinations
313 ---------------------------------------------------------------------------
315 describe "Bind and compose Stream 1" $ bindAndComposeSimple serially serially
316 describe "Bind and compose Stream 2" $ bindAndComposeSimple serially wSerially
317 describe "Bind and compose Stream 3" $ bindAndComposeSimple serially asyncly
318 describe "Bind and compose Stream 4" $ bindAndComposeSimple serially wAsyncly
319 describe "Bind and compose Stream 5" $ bindAndComposeSimple serially parallely
320 describe "Bind and compose Stream 6" $ bindAndComposeSimple serially aheadly
322 describe "Bind and compose Ahead Stream 0" $ bindAndComposeSimple aheadly aheadly
323 describe "Bind and compose Ahead Stream 1" $ bindAndComposeSimple aheadly serially
324 describe "Bind and compose Ahead Stream 2" $ bindAndComposeSimple aheadly wSerially
325 describe "Bind and compose Ahead Stream 3" $ bindAndComposeSimple aheadly asyncly
326 describe "Bind and compose Ahead Stream 4" $ bindAndComposeSimple aheadly wAsyncly
327 describe "Bind and compose Ahead Stream 5" $ bindAndComposeSimple aheadly parallely
329 describe "Bind and compose Costream 1" $ bindAndComposeSimple wSerially serially
330 describe "Bind and compose Costream 2" $ bindAndComposeSimple wSerially wSerially
331 describe "Bind and compose Costream 3" $ bindAndComposeSimple wSerially asyncly
332 describe "Bind and compose Costream 4" $ bindAndComposeSimple wSerially wAsyncly
333 describe "Bind and compose Costream 5" $ bindAndComposeSimple wSerially parallely
334 describe "Bind and compose Costream 6" $ bindAndComposeSimple wSerially aheadly
336 describe "Bind and compose Async 1" $ bindAndComposeSimple asyncly serially
337 describe "Bind and compose Async 2" $ bindAndComposeSimple asyncly wSerially
338 describe "Bind and compose Async 3" $ bindAndComposeSimple asyncly asyncly
339 describe "Bind and compose Async 4" $ bindAndComposeSimple asyncly wAsyncly
340 describe "Bind and compose Async 5" $ bindAndComposeSimple asyncly parallely
341 describe "Bind and compose Async 6" $ bindAndComposeSimple asyncly aheadly
343 describe "Bind and compose WAsync 1" $ bindAndComposeSimple wAsyncly serially
344 describe "Bind and compose WAsync 2" $ bindAndComposeSimple wAsyncly wSerially
345 describe "Bind and compose WAsync 3" $ bindAndComposeSimple wAsyncly asyncly
346 describe "Bind and compose WAsync 4" $ bindAndComposeSimple wAsyncly wAsyncly
347 describe "Bind and compose WAsync 5" $ bindAndComposeSimple wAsyncly parallely
348 describe "Bind and compose WAsync 6" $ bindAndComposeSimple wAsyncly aheadly
350 describe "Bind and compose Parallel 1" $ bindAndComposeSimple parallely serially
351 describe "Bind and compose Parallel 2" $ bindAndComposeSimple parallely wSerially
352 describe "Bind and compose Parallel 3" $ bindAndComposeSimple parallely asyncly
353 describe "Bind and compose Parallel 4" $ bindAndComposeSimple parallely wAsyncly
354 describe "Bind and compose Parallel 5" $ bindAndComposeSimple parallely parallely
355 describe "Bind and compose Parallel 6" $ bindAndComposeSimple parallely aheadly
357 let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int
358 fldr = foldr (<>) nil
359 fldl = foldl (<>) nil
361 forM_ [fldr, fldl] $ \k ->
362 describe "Bind and compose" $ bindAndComposeHierarchy serially serially k
363 forM_ [fldr, fldl] $ \k ->
364 describe "Bind and compose" $ bindAndComposeHierarchy serially wSerially k
365 forM_ [fldr, fldl] $ \k ->
366 describe "Bind and compose" $ bindAndComposeHierarchy serially asyncly k
367 forM_ [fldr, fldl] $ \k ->
368 describe "Bind and compose" $ bindAndComposeHierarchy serially wAsyncly k
369 forM_ [fldr, fldl] $ \k ->
370 describe "Bind and compose" $ bindAndComposeHierarchy serially parallely k
371 forM_ [fldr, fldl] $ \k ->
372 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy serially aheadly k
374 forM_ [fldr, fldl] $ \k ->
375 describe "Bind and compose aheadly serially" $ bindAndComposeHierarchy aheadly serially k
376 forM_ [fldr, fldl] $ \k ->
377 describe "Bind and compose aheadly wSerially" $ bindAndComposeHierarchy aheadly wSerially k
378 forM_ [fldr, fldl] $ \k ->
379 describe "Bind and compose aheadly asyncly" $ bindAndComposeHierarchy aheadly asyncly k
380 forM_ [fldr, fldl] $ \k ->
381 describe "Bind and compose aheadly wAsyncly" $ bindAndComposeHierarchy aheadly wAsyncly k
382 forM_ [fldr, fldl] $ \k ->
383 describe "Bind and compose aheadly parallely" $ bindAndComposeHierarchy aheadly parallely k
384 forM_ [fldr, fldl] $ \k ->
385 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy aheadly aheadly k
387 forM_ [fldr, fldl] $ \k ->
388 describe "Bind and compose" $ bindAndComposeHierarchy wSerially serially k
389 forM_ [fldr, fldl] $ \k ->
390 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wSerially k
391 forM_ [fldr, fldl] $ \k ->
392 describe "Bind and compose" $ bindAndComposeHierarchy wSerially asyncly k
393 forM_ [fldr, fldl] $ \k ->
394 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wAsyncly k
395 forM_ [fldr, fldl] $ \k ->
396 describe "Bind and compose" $ bindAndComposeHierarchy wSerially parallely k
397 forM_ [fldr, fldl] $ \k ->
398 describe "Bind and compose wserially aheadly" $ bindAndComposeHierarchy wSerially aheadly k
400 forM_ [fldr, fldl] $ \k ->
401 describe "Bind and compose" $ bindAndComposeHierarchy asyncly serially k
402 forM_ [fldr, fldl] $ \k ->
403 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wSerially k
404 forM_ [fldr, fldl] $ \k ->
405 describe "Bind and compose" $ bindAndComposeHierarchy asyncly asyncly k
406 forM_ [fldr, fldl] $ \k ->
407 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wAsyncly k
408 forM_ [fldr, fldl] $ \k ->
409 describe "Bind and compose" $ bindAndComposeHierarchy asyncly parallely k
410 forM_ [fldr, fldl] $ \k ->
411 describe "Bind and compose asyncly aheadly" $ bindAndComposeHierarchy asyncly aheadly k
413 forM_ [fldr, fldl] $ \k ->
414 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly serially k
415 forM_ [fldr, fldl] $ \k ->
416 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wSerially k
417 forM_ [fldr, fldl] $ \k ->
418 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly asyncly k
419 forM_ [fldr, fldl] $ \k ->
420 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wAsyncly k
421 forM_ [fldr, fldl] $ \k ->
422 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly parallely k
423 forM_ [fldr, fldl] $ \k ->
424 describe "Bind and compose wAsyncly aheadly" $ bindAndComposeHierarchy wAsyncly aheadly k
426 forM_ [fldr, fldl] $ \k ->
427 describe "Bind and compose" $ bindAndComposeHierarchy parallely serially k
428 forM_ [fldr, fldl] $ \k ->
429 describe "Bind and compose" $ bindAndComposeHierarchy parallely wSerially k
430 forM_ [fldr, fldl] $ \k ->
431 describe "Bind and compose" $ bindAndComposeHierarchy parallely asyncly k
432 forM_ [fldr, fldl] $ \k ->
433 describe "Bind and compose" $ bindAndComposeHierarchy parallely wAsyncly k
434 forM_ [fldr, fldl] $ \k ->
435 describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k
436 forM_ [fldr, fldl] $ \k ->
437 describe "Bind and compose parallely aheadly" $ bindAndComposeHierarchy parallely aheadly k
439 -- Nest two lists using different styles of product compositions
440 it "Nests two streams using monadic serial composition" nestTwoSerial
441 it "Nests two streams using monadic ahead composition" nestTwoAhead
442 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
443 it "Nests two streams using monadic Async composition" nestTwoAsync
444 it "Nests two streams using monadic WAsync composition" nestTwoWAsync
445 it "Nests two streams using monadic parallel composition" nestTwoParallel
447 it "Nests two streams using applicative serial composition" nestTwoSerialApp
448 it "Nests two streams using applicative ahead composition" nestTwoAheadApp
449 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
450 it "Nests two streams using applicative Async composition" nestTwoAsyncApp
451 it "Nests two streams using applicative WAsync composition" nestTwoWAsyncApp
452 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
454 ---------------------------------------------------------------------------
455 -- TBD Bind and Bind combinations
456 ---------------------------------------------------------------------------
458 -- TBD combine all binds and all compose in one example
459 describe "Miscellaneous combined examples" mixedOps
460 describe "Miscellaneous combined examples aheadly" mixedOpsAheadly
461 describe "Simple MonadError and MonadThrow" simpleMonadError
463 {-
464 describe "Composed MonadError serially" $ composeWithMonadError serially
465 describe "Composed MonadError wSerially" $ composeWithMonadError wSerially
466 describe "Composed MonadError asyncly" $ composeWithMonadError asyncly
467 describe "Composed MonadError wAsyncly" $ composeWithMonadError wAsyncly
468 -}
470 describe "Composed MonadThrow serially" $ composeWithMonadThrow serially
471 describe "Composed MonadThrow wSerially" $ composeWithMonadThrow wSerially
472 describe "Composed MonadThrow asyncly" $ composeWithMonadThrow asyncly
473 describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow wAsyncly
474 describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely
475 describe "Composed MonadThrow aheadly" $ composeWithMonadThrow aheadly
477 describe "take on infinite concurrent stream" $ takeInfinite asyncly
478 describe "take on infinite concurrent stream" $ takeInfinite wAsyncly
479 describe "take on infinite concurrent stream" $ takeInfinite aheadly
481 ---------------------------------------------------------------------------
482 -- Some ad-hoc tests that failed at times
483 ---------------------------------------------------------------------------
485 it "takes n from stream of streams" (takeCombined 1 aheadly)
486 it "takes n from stream of streams" (takeCombined 2 asyncly)
487 it "takes n from stream of streams" (takeCombined 3 wAsyncly)
489 ---------------------------------------------------------------------------
490 -- Left folds are strict enough
491 ---------------------------------------------------------------------------
493#ifdef DEVBUILD
494 it "foldx is strict enough" checkFoldxStrictness
495 it "scanx is strict enough" checkScanxStrictness
496 it "foldxM is strict enough" (checkFoldMStrictness foldxMStrictCheck)
497#endif
498 it "foldl' is strict enough" checkFoldl'Strictness
499 it "scanl' is strict enough" checkScanl'Strictness
500 it "foldlM' is strict enough" (checkFoldMStrictness foldlM'StrictCheck)
501 it "scanlM' is strict enough" (checkScanlMStrictness scanlM'StrictCheck)
503 ---------------------------------------------------------------------------
504 -- Right folds are lazy enough
505 ---------------------------------------------------------------------------
507 it "foldrM is lazy enough" checkFoldrLaziness
509 ---------------------------------------------------------------------------
510 -- Monadic state snapshot in concurrent tasks
511 ---------------------------------------------------------------------------
513 it "asyncly maintains independent states in concurrent tasks"
514 (monadicStateSnapshot asyncly)
515 it "asyncly limited maintains independent states in concurrent tasks"
516 (monadicStateSnapshot (asyncly . S.take 10000))
517 it "wAsyncly maintains independent states in concurrent tasks"
518 (monadicStateSnapshot wAsyncly)
519 it "wAsyncly limited maintains independent states in concurrent tasks"
520 (monadicStateSnapshot (wAsyncly . S.take 10000))
521 it "aheadly maintains independent states in concurrent tasks"
522 (monadicStateSnapshot aheadly)
523 it "aheadly limited maintains independent states in concurrent tasks"
524 (monadicStateSnapshot (aheadly . S.take 10000))
525 it "parallely maintains independent states in concurrent tasks"
526 (monadicStateSnapshot parallely)
528 it "async maintains independent states in concurrent tasks"
529 (monadicStateSnapshotOp async)
530 it "ahead maintains independent states in concurrent tasks"
531 (monadicStateSnapshotOp ahead)
532 it "wAsync maintains independent states in concurrent tasks"
533 (monadicStateSnapshotOp wAsync)
534 it "parallel maintains independent states in concurrent tasks"
535 (monadicStateSnapshotOp Streamly.parallel)
537 ---------------------------------------------------------------------------
538 -- Slower tests are at the end
539 ---------------------------------------------------------------------------
541 ---------------------------------------------------------------------------
542 -- Thread limits
543 ---------------------------------------------------------------------------
545 it "asyncly crosses thread limit (2000 threads)" $
546 S.drain (asyncly $ fold $
547 replicate 2000 $ S.yieldM $ threadDelay 1000000)
548 `shouldReturn` ()
550 it "aheadly crosses thread limit (4000 threads)" $
551 S.drain (aheadly $ fold $
552 replicate 4000 $ S.yieldM $ threadDelay 1000000)
553 `shouldReturn` ()
555-- Each snapshot carries an independent state. Multiple parallel tasks should
556-- not affect each other's state. This is especially important when we run
557-- multiple tasks in a single thread.
558snapshot :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()
559snapshot =
560 -- We deliberately use a replicate count 1 here, because a lower count
561 -- catches problems that a higher count doesn't.
562 S.replicateM 1 $ do
563 -- Even though we modify the state here it should not reflect in other
564 -- parallel tasks, it is local to each concurrent task.
565 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==1))
566 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))
568snapshot1 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()
569snapshot1 = S.replicateM 1000 $
570 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))
572snapshot2 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()
573snapshot2 = S.replicateM 1000 $
574 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))
576stateComp
577 :: ( IsStream t
578 , MonadAsync m
579 , Semigroup (t m ())
580 , MonadIO (t m)
581 , MonadState Int m
582 , MonadState Int (t m)
583 )
584 => t m ()
585stateComp = do
586 -- Each task in a concurrent composition inherits the state and maintains
587 -- its own modifications to it, not affecting the parent computation.
588 snapshot <> (modify (+1) >> (snapshot1 <> snapshot2))
589 -- The above modify statement does not affect our state because that is
590 -- used in a parallel composition. In a serial composition it will affect
591 -- our state.
592 get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))
594monadicStateSnapshot
595 :: ( IsStream t
596 , Semigroup (t (StateT Int IO) ())
597 , MonadIO (t (StateT Int IO))
598 , MonadState Int (t (StateT Int IO))
599 )
600 => (t (StateT Int IO) () -> SerialT (StateT Int IO) ()) -> IO ()
601monadicStateSnapshot t = void $ runStateT (S.drain $ t stateComp) 0
603stateCompOp
604 :: ( AsyncT (StateT Int IO) ()
605 -> AsyncT (StateT Int IO) ()
606 -> AsyncT (StateT Int IO) ()
607 )
608 -> SerialT (StateT Int IO) ()
609stateCompOp op = do
610 -- Each task in a concurrent composition inherits the state and maintains
611 -- its own modifications to it, not affecting the parent computation.
612 asyncly (snapshot `op` (modify (+1) >> (snapshot1 `op` snapshot2)))
613 -- The above modify statement does not affect our state because that is
614 -- used in a parallel composition. In a serial composition it will affect
615 -- our state.
616 get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))
618monadicStateSnapshotOp
619 :: ( AsyncT (StateT Int IO) ()
620 -> AsyncT (StateT Int IO) ()
621 -> AsyncT (StateT Int IO) ()
622 )
623 -> IO ()
624monadicStateSnapshotOp op = void $ runStateT (S.drain $ stateCompOp op) 0
626takeCombined :: (Monad m, Semigroup (t m Int), Show a, Eq a, IsStream t)
627 => Int -> (t m Int -> SerialT IO a) -> IO ()
628takeCombined n t = do
629 let constr = S.fromFoldable
630 r <- (S.toList . t) $
631 S.take n (constr ([] :: [Int]) <> constr ([] :: [Int]))
632 r `shouldBe` []
634checkFoldrLaziness :: IO ()
635checkFoldrLaziness = do
636 S.foldrM (\x xs -> if odd x then return True else xs)
637 (return False) (S.fromList (2:4:5:undefined :: [Int]))
638 `shouldReturn` True
640 S.toList (S.foldrS (\x xs -> if odd x then return True else xs)
641 (return False)
642 $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))
643 `shouldReturn` [True]
645 S.toList (S.foldrT (\x xs -> if odd x then return True else xs)
646 (return False)
647 $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))
648 `shouldReturn` [True]
650#ifdef DEVBUILD
651checkFoldxStrictness :: IO ()
652checkFoldxStrictness = do
653 let s = return (1 :: Int) `S.consM` error "failure"
654 catch (S.foldx (\_ a -> if a == 1 then error "success" else "done")
655 "begin" id s)
656 (\e -> case e of
657 ErrorCall err -> return err
658 _ -> throw e)
659 `shouldReturn` "success"
660#endif
662checkFoldl'Strictness :: IO ()
663checkFoldl'Strictness = do
664 let s = return (1 :: Int) `S.consM` error "failure"
665 catch (S.foldl' (\_ a -> if a == 1 then error "success" else "done")
666 "begin" s)
667 (\e -> case e of
668 ErrorCall err -> return err
669 _ -> throw e)
670 `shouldReturn` "success"
672#ifdef DEVBUILD
673checkScanxStrictness :: IO ()
674checkScanxStrictness = do
675 let s = return (1 :: Int) `S.consM` error "failure"
676 catch
677 (S.drain (
678 S.scanx (\_ a ->
679 if a == 1
680 then error "success"
681 else "done")
682 "begin" id s
683 )
684 >> return "finished"
685 )
686 (\e -> case e of
687 ErrorCall err -> return err
688 _ -> throw e)
689 `shouldReturn` "success"
690#endif
692checkScanl'Strictness :: IO ()
693checkScanl'Strictness = do
694 let s = return (1 :: Int) `S.consM` error "failure"
695 catch
696 (S.drain
697 (S.scanl'
698 (\_ a ->
699 if a == 1
700 then error "success"
701 else "done")
702 "begin"
703 s)
704 >> return "finished"
705 )
706 (\e -> case e of
707 ErrorCall err -> return err
708 _ -> throw e)
709 `shouldReturn` "success"
711foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()
712foldlM'StrictCheck ref = S.foldlM' (\_ _ -> writeIORef ref 1) ()
714#ifdef DEVBUILD
715foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO ()
716foldxMStrictCheck ref = S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return
717#endif
719checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()
720checkFoldMStrictness f = do
721 ref <- newIORef 0
722 let s = return 1 `S.consM` error "x"
723 catch (f ref s) (\(_ :: ErrorCall) -> return ())
724 readIORef ref `shouldReturn` 1
726scanlM'StrictCheck :: IORef Int -> SerialT IO Int -> SerialT IO ()
727scanlM'StrictCheck ref = S.scanlM' (\_ _ -> writeIORef ref 1) ()
729checkScanlMStrictness :: (IORef Int -> SerialT IO Int -> SerialT IO ()) -> IO ()
730checkScanlMStrictness f = do
731 ref <- newIORef 0
732 let s = return 1 `S.consM` error "x"
733 catch (S.drain $ f ref s) (\(_ :: ErrorCall) -> return ())
734 readIORef ref `shouldReturn` 1
736takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
737takeInfinite t =
738 it "take 1" $
739 S.drain (t $ S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))
740 `shouldReturn` ()
742-- XXX need to test that we have promptly cleaned up everything after the error
743-- XXX We can also check the output that we are expected to get before the
744-- error occurs.
746newtype ExampleException = ExampleException String deriving (Eq, Show)
748instance Exception ExampleException
750simpleMonadError :: Spec
751simpleMonadError = do
752{-
753 it "simple runExceptT" $ do
754 (runExceptT $ S.drain $ return ())
755 `shouldReturn` (Right () :: Either String ())
756 it "simple runExceptT with error" $ do
757 (runExceptT $ S.drain $ throwError "E") `shouldReturn` Left "E"
758 -}
759 it "simple try" $
760 try (S.drain $ return ())
761 `shouldReturn` (Right () :: Either ExampleException ())
762 it "simple try with throw error" $
763 try (S.drain $ throwM $ ExampleException "E")
764 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
766composeWithMonadThrow
767 :: ( IsStream t
768 , Semigroup (t IO Int)
769 , MonadThrow (t IO)
770 )
771 => (t IO Int -> SerialT IO Int) -> Spec
772composeWithMonadThrow t = do
773 it "Compose throwM, nil" $
774 try (tl (throwM (ExampleException "E") <> S.nil))
775 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
776 it "Compose nil, throwM" $
777 try (tl (S.nil <> throwM (ExampleException "E")))
778 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
779 oneLevelNestedSum "serially" serially
780 oneLevelNestedSum "wSerially" wSerially
781 oneLevelNestedSum "asyncly" asyncly
782 oneLevelNestedSum "wAsyncly" wAsyncly
783 -- XXX add two level nesting
785 oneLevelNestedProduct "serially" serially
786 oneLevelNestedProduct "wSerially" wSerially
787 oneLevelNestedProduct "asyncly" asyncly
788 oneLevelNestedProduct "wAsyncly" wAsyncly
790 where
791 tl = S.toList . t
792 oneLevelNestedSum desc t1 =
793 it ("One level nested sum " <> desc) $ do
794 let nested = S.fromFoldable [1..10] <> throwM (ExampleException "E")
795 <> S.fromFoldable [1..10]
796 try (tl (S.nil <> t1 nested <> S.fromFoldable [1..10]))
797 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
799 oneLevelNestedProduct desc t1 =
800 it ("One level nested product" <> desc) $ do
801 let s1 = t $ S.foldMapWith (<>) return [1..4]
802 s2 = t1 $ S.foldMapWith (<>) return [5..8]
803 try $ tl (do
804 x <- adapt s1
805 y <- s2
806 if x + y > 10
807 then throwM (ExampleException "E")
808 else return (x + y)
809 )
810 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
812_composeWithMonadError
813 :: ( IsStream t
814 , Semigroup (t (ExceptT String IO) Int)
815 , MonadError String (t (ExceptT String IO))
816 )
817 => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec
818_composeWithMonadError t = do
819 let tl = S.toList . t
820 it "Compose throwError, nil" $
821 runExceptT (tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"
822 it "Compose nil, error" $
823 runExceptT (tl (S.nil <> throwError "E")) `shouldReturn` Left "E"
825nestTwoSerial :: Expectation
826nestTwoSerial =
827 let s1 = S.foldMapWith (<>) return [1..4]
828 s2 = S.foldMapWith (<>) return [5..8]
829 in toListSerial (do
830 x <- s1
831 y <- s2
832 return (x + y)
833 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
835nestTwoAhead :: Expectation
836nestTwoAhead =
837 let s1 = S.foldMapWith (<>) return [1..4]
838 s2 = S.foldMapWith (<>) return [5..8]
839 in (S.toList . aheadly) (do
840 x <- s1
841 y <- s2
842 return (x + y)
843 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
845nestTwoSerialApp :: Expectation
846nestTwoSerialApp =
847 let s1 = S.foldMapWith (<>) return [1..4]
848 s2 = S.foldMapWith (<>) return [5..8]
849 in toListSerial ((+) <$> s1 <*> s2)
850 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
852nestTwoAheadApp :: Expectation
853nestTwoAheadApp =
854 let s1 = S.foldMapWith (<>) return [1..4]
855 s2 = S.foldMapWith (<>) return [5..8]
856 in (S.toList . aheadly) ((+) <$> s1 <*> s2)
857 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
859nestTwoInterleaved :: Expectation
860nestTwoInterleaved =
861 let s1 = S.foldMapWith (<>) return [1..4]
862 s2 = S.foldMapWith (<>) return [5..8]
863 in toListInterleaved (do
864 x <- s1
865 y <- s2
866 return (x + y)
867 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
869nestTwoInterleavedApp :: Expectation
870nestTwoInterleavedApp =
871 let s1 = S.foldMapWith (<>) return [1..4]
872 s2 = S.foldMapWith (<>) return [5..8]
873 in toListInterleaved ((+) <$> s1 <*> s2)
874 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
876nestTwoAsync :: Expectation
877nestTwoAsync =
878 let s1 = S.foldMapWith (<>) return [1..4]
879 s2 = S.foldMapWith (<>) return [5..8]
880 in sort <$> toListAsync (do
881 x <- s1
882 y <- s2
883 return (x + y))
884 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
886nestTwoAsyncApp :: Expectation
887nestTwoAsyncApp =
888 let s1 = S.foldMapWith (<>) return [1..4]
889 s2 = S.foldMapWith (<>) return [5..8]
890 in sort <$> toListAsync ((+) <$> s1 <*> s2)
891 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
893nestTwoWAsync :: Expectation
894nestTwoWAsync =
895 let s1 = S.foldMapWith (<>) return [1..4]
896 s2 = S.foldMapWith (<>) return [5..8]
897 in sort <$> (S.toList . wAsyncly) (do
898 x <- s1
899 y <- s2
900 return (x + y))
901 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
903nestTwoParallel :: Expectation
904nestTwoParallel =
905 let s1 = S.foldMapWith (<>) return [1..4]
906 s2 = S.foldMapWith (<>) return [5..8]
907 in sort <$> (S.toList . parallely) (do
908 x <- s1
909 y <- s2
910 return (x + y))
911 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
913nestTwoWAsyncApp :: Expectation
914nestTwoWAsyncApp =
915 let s1 = S.foldMapWith (<>) return [1..4]
916 s2 = S.foldMapWith (<>) return [5..8]
917 in sort <$> (S.toList . wAsyncly) ((+) <$> s1 <*> s2)
918 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
920nestTwoParallelApp :: Expectation
921nestTwoParallelApp =
922 let s1 = S.foldMapWith (<>) return [1..4]
923 s2 = S.foldMapWith (<>) return [5..8]
924 in sort <$> (S.toList . parallely) ((+) <$> s1 <*> s2)
925 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
927interleaveCheck :: IsStream t
928 => (t IO Int -> SerialT IO Int)
929 -> (t IO Int -> t IO Int -> t IO Int)
930 -> Spec
931interleaveCheck t f =
932 it "Interleave four" $
933 (S.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))
934 `shouldReturn` [0, 100, 1, 101]
936parallelCheck :: (IsStream t, Monad (t IO))
937 => (t IO Int -> SerialT IO Int)
938 -> (t IO Int -> t IO Int -> t IO Int)
939 -> Spec
940parallelCheck t f = do
941 it "Parallel ordering left associated" $
942 (S.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)
943 `shouldReturn` [1..4]
945 it "Parallel ordering right associated" $
946 (S.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
947 `shouldReturn` [1..4]
949 where event n = S.yieldM (threadDelay (n * 200000)) >> return n
951compose :: (IsStream t, Semigroup (t IO Int))
952 => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec
953compose t z srt = do
954 -- XXX these should get covered by the property tests
955 it "Compose mempty, mempty" $
956 tl (z <> z) `shouldReturn` ([] :: [Int])
957 it "Compose empty at the beginning" $
958 tl (z <> singleton 1) `shouldReturn` [1]
959 it "Compose empty at the end" $
960 tl (singleton 1 <> z) `shouldReturn` [1]
961 it "Compose two" $
962 srt <$> tl (singleton 0 <> singleton 1)
963 `shouldReturn` [0, 1]
964 it "Compose many" $
965 srt <$> tl (S.forEachWith (<>) [1..100] singleton)
966 `shouldReturn` [1..100]
968 -- These are not covered by the property tests
969 it "Compose three - empty in the middle" $
970 srt <$> tl (singleton 0 <> z <> singleton 1)
971 `shouldReturn` [0, 1]
972 it "Compose left associated" $
973 srt <$> tl (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3)
974 `shouldReturn` [0, 1, 2, 3]
975 it "Compose right associated" $
976 srt <$> tl (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3)))
977 `shouldReturn` [0, 1, 2, 3]
978 it "Compose hierarchical (multiple levels)" $
979 srt <$> tl (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))
980 <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))
981 `shouldReturn` [0..7]
982 where tl = S.toList . t
984composeAndComposeSimple
985 :: ( IsStream t1, Semigroup (t1 IO Int)
986 , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)
987#if __GLASGOW_HASKELL__ < 804
988 , Semigroup (t2 IO Int)
989#endif
990 )
991 => (t1 IO Int -> SerialT IO Int)
992 -> (t2 IO Int -> t2 IO Int)
993 -> [[Int]] -> Spec
994composeAndComposeSimple t1 t2 answer = do
995 let rfold = adapt . t2 . S.foldMapWith (<>) return
996 it "Compose right associated outer expr, right folded inner" $
997 (S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9]))
998 `shouldReturn` head answer
1000 it "Compose left associated outer expr, right folded inner" $
1001 (S.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9])
1002 `shouldReturn` (answer !! 1)
1004 let lfold xs = adapt $ t2 $ foldl (<>) mempty $ fmap return xs
1005 it "Compose right associated outer expr, left folded inner" $
1006 (S.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9]))
1007 `shouldReturn` (answer !! 2)
1009 it "Compose left associated outer expr, left folded inner" $
1010 (S.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9])
1011 `shouldReturn` (answer !! 3)
1013loops
1014 :: (IsStream t, Semigroup (t IO Int), Monad (t IO))
1015 => (t IO Int -> t IO Int)
1016 -> ([Int] -> [Int])
1017 -> ([Int] -> [Int])
1018 -> Spec
1019loops t tsrt hsrt = do
1020 it "Tail recursive loop" $ (tsrt <$> (S.toList . adapt) (loopTail 0))
1021 `shouldReturn` [0..3]
1023 it "Head recursive loop" $ (hsrt <$> (S.toList . adapt) (loopHead 0))
1024 `shouldReturn` [0..3]
1026 where
1027 loopHead x = do
1028 -- this print line is important for the test (causes a bind)
1029 S.yieldM $ putStrLn "LoopHead..."
1030 t $ (if x < 3 then loopHead (x + 1) else nil) <> return x
1032 loopTail x = do
1033 -- this print line is important for the test (causes a bind)
1034 S.yieldM $ putStrLn "LoopTail..."
1035 t $ return x <> (if x < 3 then loopTail (x + 1) else nil)
1037bindAndComposeSimple
1038 :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))
1039 => (t1 IO Int -> SerialT IO Int)
1040 -> (t2 IO Int -> t2 IO Int)
1041 -> Spec
1042bindAndComposeSimple t1 t2 = do
1043 -- XXX need a bind in the body of forEachWith instead of a simple return
1044 it "Compose many (right fold) with bind" $
1045 (sort <$> (S.toList . t1)
1046 (adapt . t2 $ S.forEachWith (<>) [1..10 :: Int] return))
1047 `shouldReturn` [1..10]
1049 it "Compose many (left fold) with bind" $
1050 let forL xs k = foldl (<>) nil $ fmap k xs
1051 in (sort <$> (S.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return))
1052 `shouldReturn` [1..10]
1054bindAndComposeHierarchy
1055 :: ( IsStream t1, Monad (t1 IO)
1056 , IsStream t2, Monad (t2 IO))
1057 => (t1 IO Int -> SerialT IO Int)
1058 -> (t2 IO Int -> t2 IO Int)
1059 -> ([t2 IO Int] -> t2 IO Int)
1060 -> Spec
1061bindAndComposeHierarchy t1 t2 g =
1062 it "Bind and compose nested" $
1063 (sort <$> (S.toList . t1) bindComposeNested)
1064 `shouldReturn` (sort (
1065 [12, 18]
1066 <> replicate 3 13
1067 <> replicate 3 17
1068 <> replicate 6 14
1069 <> replicate 6 16
1070 <> replicate 7 15) :: [Int])
1072 where
1074 -- bindComposeNested :: WAsyncT IO Int
1075 bindComposeNested =
1076 let c1 = tripleCompose (return 1) (return 2) (return 3)
1077 c2 = tripleCompose (return 4) (return 5) (return 6)
1078 c3 = tripleCompose (return 7) (return 8) (return 9)
1079 b = tripleBind c1 c2 c3
1080-- it seems to be causing a huge space leak in hspec so disabling this for now
1081-- c = tripleCompose b b b
1082-- m = tripleBind c c c
1083-- in m
1084 in b
1086 tripleCompose a b c = adapt . t2 $ g [a, b, c]
1087 tripleBind mx my mz =
1088 mx >>= \x -> my
1089 >>= \y -> mz
1090 >>= \z -> return (x + y + z)
1092mixedOps :: Spec
1093mixedOps =
1094 it "Compose many ops" $
1095 (sort <$> toListSerial composeMixed)
1096 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
1097 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
1098 ] :: [Int])
1099 where
1101 composeMixed :: SerialT IO Int
1102 composeMixed = do
1103 S.yieldM $ return ()
1104 S.yieldM $ putStr ""
1105 let x = 1
1106 let y = 2
1107 z <- do
1108 x1 <- wAsyncly $ return 1 <> return 2
1109 S.yieldM $ return ()
1110 S.yieldM $ putStr ""
1111 y1 <- asyncly $ return 1 <> return 2
1112 z1 <- do
1113 x11 <- return 1 <> return 2
1114 y11 <- asyncly $ return 1 <> return 2
1115 z11 <- wSerially $ return 1 <> return 2
1116 S.yieldM $ return ()
1117 S.yieldM $ putStr ""
1118 return (x11 + y11 + z11)
1119 return (x1 + y1 + z1)
1120 return (x + y + z)
1122mixedOpsAheadly :: Spec
1123mixedOpsAheadly =
1124 it "Compose many ops" $
1125 (sort <$> toListSerial composeMixed)
1126 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
1127 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
1128 ] :: [Int])
1129 where
1131 composeMixed :: SerialT IO Int
1132 composeMixed = do
1133 S.yieldM $ return ()
1134 S.yieldM $ putStr ""
1135 let x = 1
1136 let y = 2
1137 z <- do
1138 x1 <- wAsyncly $ return 1 <> return 2
1139 S.yieldM $ return ()
1140 S.yieldM $ putStr ""
1141 y1 <- aheadly $ return 1 <> return 2
1142 z1 <- do
1143 x11 <- return 1 <> return 2
1144 y11 <- aheadly $ return 1 <> return 2
1145 z11 <- parallely $ return 1 <> return 2
1146 S.yieldM $ return ()
1147 S.yieldM $ putStr ""
1148 return (x11 + y11 + z11)
1149 return (x1 + y1 + z1)
1150 return (x + y + z)