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