git.iko.soy/streamly
on 57fad21 help sign in
streamly/test/Main.hs
1120 lines 47 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 runStream . 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 (runStream . serially) (return (0 :: Int)) `shouldReturn` ()
197 it "simple serially with IO" $
198 (runStream . 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 -- Folds are strict enough
491 ---------------------------------------------------------------------------
493 it "foldx is strict enough" checkFoldxStrictness
494 it "foldl' is strict enough" checkFoldl'Strictness
495 it "scanx is strict enough" checkScanxStrictness
496 it "scanl' is strict enough" checkScanl'Strictness
497 it "foldxM is strict enough" (checkFoldMStrictness foldxMStrictCheck)
498 it "foldlM' is strict enough" (checkFoldMStrictness foldlM'StrictCheck)
499 it "scanlM' is strict enough" (checkScanlMStrictness scanlM'StrictCheck)
501 ---------------------------------------------------------------------------
502 -- Monadic state snapshot in concurrent tasks
503 ---------------------------------------------------------------------------
505 it "asyncly maintains independent states in concurrent tasks"
506 (monadicStateSnapshot asyncly)
507 it "asyncly limited maintains independent states in concurrent tasks"
508 (monadicStateSnapshot (asyncly . S.take 10000))
509 it "wAsyncly maintains independent states in concurrent tasks"
510 (monadicStateSnapshot wAsyncly)
511 it "wAsyncly limited maintains independent states in concurrent tasks"
512 (monadicStateSnapshot (wAsyncly . S.take 10000))
513 it "aheadly maintains independent states in concurrent tasks"
514 (monadicStateSnapshot aheadly)
515 it "aheadly limited maintains independent states in concurrent tasks"
516 (monadicStateSnapshot (aheadly . S.take 10000))
517 it "parallely maintains independent states in concurrent tasks"
518 (monadicStateSnapshot parallely)
520 it "async maintains independent states in concurrent tasks"
521 (monadicStateSnapshotOp async)
522 it "ahead maintains independent states in concurrent tasks"
523 (monadicStateSnapshotOp ahead)
524 it "wAsync maintains independent states in concurrent tasks"
525 (monadicStateSnapshotOp wAsync)
526 it "parallel maintains independent states in concurrent tasks"
527 (monadicStateSnapshotOp Streamly.parallel)
529 ---------------------------------------------------------------------------
530 -- Slower tests are at the end
531 ---------------------------------------------------------------------------
533 ---------------------------------------------------------------------------
534 -- Thread limits
535 ---------------------------------------------------------------------------
537 it "asyncly crosses thread limit (2000 threads)" $
538 runStream (asyncly $ fold $
539 replicate 2000 $ S.yieldM $ threadDelay 1000000)
540 `shouldReturn` ()
542 it "aheadly crosses thread limit (4000 threads)" $
543 runStream (aheadly $ fold $
544 replicate 4000 $ S.yieldM $ threadDelay 1000000)
545 `shouldReturn` ()
547-- Each snapshot carries an independent state. Multiple parallel tasks should
548-- not affect each other's state. This is especially important when we run
549-- multiple tasks in a single thread.
550snapshot :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()
551snapshot =
552 -- We deliberately use a replicate count 1 here, because a lower count
553 -- catches problems that a higher count doesn't.
554 S.replicateM 1 $ do
555 -- Even though we modify the state here it should not reflect in other
556 -- parallel tasks, it is local to each concurrent task.
557 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==1))
558 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))
560snapshot1 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()
561snapshot1 = S.replicateM 1000 $
562 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))
564snapshot2 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()
565snapshot2 = S.replicateM 1000 $
566 modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))
568stateComp
569 :: ( IsStream t
570 , MonadAsync m
571 , Semigroup (t m ())
572 , MonadIO (t m)
573 , MonadState Int m
574 , MonadState Int (t m)
575 )
576 => t m ()
577stateComp = do
578 -- Each task in a concurrent composition inherits the state and maintains
579 -- its own modifications to it, not affecting the parent computation.
580 snapshot <> (modify (+1) >> (snapshot1 <> snapshot2))
581 -- The above modify statement does not affect our state because that is
582 -- used in a parallel composition. In a serial composition it will affect
583 -- our state.
584 get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))
586monadicStateSnapshot
587 :: ( IsStream t
588 , Semigroup (t (StateT Int IO) ())
589 , MonadIO (t (StateT Int IO))
590 , MonadState Int (t (StateT Int IO))
591 )
592 => (t (StateT Int IO) () -> SerialT (StateT Int IO) ()) -> IO ()
593monadicStateSnapshot t = void $ runStateT (runStream $ t stateComp) 0
595stateCompOp
596 :: ( AsyncT (StateT Int IO) ()
597 -> AsyncT (StateT Int IO) ()
598 -> AsyncT (StateT Int IO) ()
599 )
600 -> SerialT (StateT Int IO) ()
601stateCompOp op = do
602 -- Each task in a concurrent composition inherits the state and maintains
603 -- its own modifications to it, not affecting the parent computation.
604 asyncly (snapshot `op` (modify (+1) >> (snapshot1 `op` snapshot2)))
605 -- The above modify statement does not affect our state because that is
606 -- used in a parallel composition. In a serial composition it will affect
607 -- our state.
608 get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))
610monadicStateSnapshotOp
611 :: ( AsyncT (StateT Int IO) ()
612 -> AsyncT (StateT Int IO) ()
613 -> AsyncT (StateT Int IO) ()
614 )
615 -> IO ()
616monadicStateSnapshotOp op = void $ runStateT (runStream $ stateCompOp op) 0
618takeCombined :: (Monad m, Semigroup (t m Int), Show a, Eq a, IsStream t)
619 => Int -> (t m Int -> SerialT IO a) -> IO ()
620takeCombined n t = do
621 let constr = S.fromFoldable
622 r <- (S.toList . t) $
623 S.take n (constr ([] :: [Int]) <> constr ([] :: [Int]))
624 r `shouldBe` []
626checkFoldxStrictness :: IO ()
627checkFoldxStrictness = do
628 let s = return (1 :: Int) `S.consM` error "failure"
629 catch (S.foldx (\_ a -> if a == 1 then error "success" else "done")
630 "begin" id s)
631 (\e -> case e of
632 ErrorCall err -> return err
633 _ -> throw e)
634 `shouldReturn` "success"
636checkFoldl'Strictness :: IO ()
637checkFoldl'Strictness = do
638 let s = return (1 :: Int) `S.consM` error "failure"
639 catch (S.foldl' (\_ a -> if a == 1 then error "success" else "done")
640 "begin" s)
641 (\e -> case e of
642 ErrorCall err -> return err
643 _ -> throw e)
644 `shouldReturn` "success"
646checkScanxStrictness :: IO ()
647checkScanxStrictness = do
648 let s = return (1 :: Int) `S.consM` error "failure"
649 catch
650 (runStream (
651 S.scanx (\_ a ->
652 if a == 1
653 then error "success"
654 else "done")
655 "begin" id s
656 )
657 >> return "finished"
658 )
659 (\e -> case e of
660 ErrorCall err -> return err
661 _ -> throw e)
662 `shouldReturn` "success"
664checkScanl'Strictness :: IO ()
665checkScanl'Strictness = do
666 let s = return (1 :: Int) `S.consM` error "failure"
667 catch
668 (runStream
669 (S.scanl'
670 (\_ a ->
671 if a == 1
672 then error "success"
673 else "done")
674 "begin"
675 s)
676 >> return "finished"
677 )
678 (\e -> case e of
679 ErrorCall err -> return err
680 _ -> throw e)
681 `shouldReturn` "success"
683foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()
684foldlM'StrictCheck ref = S.foldlM' (\_ _ -> writeIORef ref 1) ()
686foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO ()
687foldxMStrictCheck ref = S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return
689checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()
690checkFoldMStrictness f = do
691 ref <- newIORef 0
692 let s = return 1 `S.consM` error "x"
693 catch (f ref s) (\(_ :: ErrorCall) -> return ())
694 readIORef ref `shouldReturn` 1
696scanlM'StrictCheck :: IORef Int -> SerialT IO Int -> SerialT IO ()
697scanlM'StrictCheck ref = S.scanlM' (\_ _ -> writeIORef ref 1) ()
699checkScanlMStrictness :: (IORef Int -> SerialT IO Int -> SerialT IO ()) -> IO ()
700checkScanlMStrictness f = do
701 ref <- newIORef 0
702 let s = return 1 `S.consM` error "x"
703 catch (runStream $ f ref s) (\(_ :: ErrorCall) -> return ())
704 readIORef ref `shouldReturn` 1
706takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
707takeInfinite t =
708 it "take 1" $
709 runStream (t $ S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))
710 `shouldReturn` ()
712-- XXX need to test that we have promptly cleaned up everything after the error
713-- XXX We can also check the output that we are expected to get before the
714-- error occurs.
716newtype ExampleException = ExampleException String deriving (Eq, Show)
718instance Exception ExampleException
720simpleMonadError :: Spec
721simpleMonadError = do
722{-
723 it "simple runExceptT" $ do
724 (runExceptT $ runStream $ return ())
725 `shouldReturn` (Right () :: Either String ())
726 it "simple runExceptT with error" $ do
727 (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"
728 -}
729 it "simple try" $
730 try (runStream $ return ())
731 `shouldReturn` (Right () :: Either ExampleException ())
732 it "simple try with throw error" $
733 try (runStream $ throwM $ ExampleException "E")
734 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
736composeWithMonadThrow
737 :: ( IsStream t
738 , Semigroup (t IO Int)
739 , MonadThrow (t IO)
740 )
741 => (t IO Int -> SerialT IO Int) -> Spec
742composeWithMonadThrow t = do
743 it "Compose throwM, nil" $
744 try (tl (throwM (ExampleException "E") <> S.nil))
745 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
746 it "Compose nil, throwM" $
747 try (tl (S.nil <> throwM (ExampleException "E")))
748 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
749 oneLevelNestedSum "serially" serially
750 oneLevelNestedSum "wSerially" wSerially
751 oneLevelNestedSum "asyncly" asyncly
752 oneLevelNestedSum "wAsyncly" wAsyncly
753 -- XXX add two level nesting
755 oneLevelNestedProduct "serially" serially
756 oneLevelNestedProduct "wSerially" wSerially
757 oneLevelNestedProduct "asyncly" asyncly
758 oneLevelNestedProduct "wAsyncly" wAsyncly
760 where
761 tl = S.toList . t
762 oneLevelNestedSum desc t1 =
763 it ("One level nested sum " <> desc) $ do
764 let nested = S.fromFoldable [1..10] <> throwM (ExampleException "E")
765 <> S.fromFoldable [1..10]
766 try (tl (S.nil <> t1 nested <> S.fromFoldable [1..10]))
767 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
769 oneLevelNestedProduct desc t1 =
770 it ("One level nested product" <> desc) $ do
771 let s1 = t $ foldMapWith (<>) return [1..4]
772 s2 = t1 $ foldMapWith (<>) return [5..8]
773 try $ tl (do
774 x <- adapt s1
775 y <- s2
776 if x + y > 10
777 then throwM (ExampleException "E")
778 else return (x + y)
779 )
780 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
782_composeWithMonadError
783 :: ( IsStream t
784 , Semigroup (t (ExceptT String IO) Int)
785 , MonadError String (t (ExceptT String IO))
786 )
787 => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec
788_composeWithMonadError t = do
789 let tl = S.toList . t
790 it "Compose throwError, nil" $
791 runExceptT (tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"
792 it "Compose nil, error" $
793 runExceptT (tl (S.nil <> throwError "E")) `shouldReturn` Left "E"
795nestTwoSerial :: Expectation
796nestTwoSerial =
797 let s1 = foldMapWith (<>) return [1..4]
798 s2 = foldMapWith (<>) return [5..8]
799 in toListSerial (do
800 x <- s1
801 y <- s2
802 return (x + y)
803 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
805nestTwoAhead :: Expectation
806nestTwoAhead =
807 let s1 = foldMapWith (<>) return [1..4]
808 s2 = foldMapWith (<>) return [5..8]
809 in (S.toList . aheadly) (do
810 x <- s1
811 y <- s2
812 return (x + y)
813 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
815nestTwoSerialApp :: Expectation
816nestTwoSerialApp =
817 let s1 = foldMapWith (<>) return [1..4]
818 s2 = foldMapWith (<>) return [5..8]
819 in toListSerial ((+) <$> s1 <*> s2)
820 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
822nestTwoAheadApp :: Expectation
823nestTwoAheadApp =
824 let s1 = foldMapWith (<>) return [1..4]
825 s2 = foldMapWith (<>) return [5..8]
826 in (S.toList . aheadly) ((+) <$> s1 <*> s2)
827 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
829nestTwoInterleaved :: Expectation
830nestTwoInterleaved =
831 let s1 = foldMapWith (<>) return [1..4]
832 s2 = foldMapWith (<>) return [5..8]
833 in toListInterleaved (do
834 x <- s1
835 y <- s2
836 return (x + y)
837 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
839nestTwoInterleavedApp :: Expectation
840nestTwoInterleavedApp =
841 let s1 = foldMapWith (<>) return [1..4]
842 s2 = foldMapWith (<>) return [5..8]
843 in toListInterleaved ((+) <$> s1 <*> s2)
844 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
846nestTwoAsync :: Expectation
847nestTwoAsync =
848 let s1 = foldMapWith (<>) return [1..4]
849 s2 = foldMapWith (<>) return [5..8]
850 in sort <$> toListAsync (do
851 x <- s1
852 y <- s2
853 return (x + y))
854 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
856nestTwoAsyncApp :: Expectation
857nestTwoAsyncApp =
858 let s1 = foldMapWith (<>) return [1..4]
859 s2 = foldMapWith (<>) return [5..8]
860 in sort <$> toListAsync ((+) <$> s1 <*> s2)
861 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
863nestTwoWAsync :: Expectation
864nestTwoWAsync =
865 let s1 = foldMapWith (<>) return [1..4]
866 s2 = foldMapWith (<>) return [5..8]
867 in sort <$> (S.toList . wAsyncly) (do
868 x <- s1
869 y <- s2
870 return (x + y))
871 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
873nestTwoParallel :: Expectation
874nestTwoParallel =
875 let s1 = foldMapWith (<>) return [1..4]
876 s2 = foldMapWith (<>) return [5..8]
877 in sort <$> (S.toList . parallely) (do
878 x <- s1
879 y <- s2
880 return (x + y))
881 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
883nestTwoWAsyncApp :: Expectation
884nestTwoWAsyncApp =
885 let s1 = foldMapWith (<>) return [1..4]
886 s2 = foldMapWith (<>) return [5..8]
887 in sort <$> (S.toList . wAsyncly) ((+) <$> s1 <*> s2)
888 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
890nestTwoParallelApp :: Expectation
891nestTwoParallelApp =
892 let s1 = foldMapWith (<>) return [1..4]
893 s2 = foldMapWith (<>) return [5..8]
894 in sort <$> (S.toList . parallely) ((+) <$> s1 <*> s2)
895 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
897interleaveCheck :: IsStream t
898 => (t IO Int -> SerialT IO Int)
899 -> (t IO Int -> t IO Int -> t IO Int)
900 -> Spec
901interleaveCheck t f =
902 it "Interleave four" $
903 (S.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))
904 `shouldReturn` [0, 100, 1, 101]
906parallelCheck :: (IsStream t, Monad (t IO))
907 => (t IO Int -> SerialT IO Int)
908 -> (t IO Int -> t IO Int -> t IO Int)
909 -> Spec
910parallelCheck t f = do
911 it "Parallel ordering left associated" $
912 (S.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)
913 `shouldReturn` [1..4]
915 it "Parallel ordering right associated" $
916 (S.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
917 `shouldReturn` [1..4]
919 where event n = S.yieldM (threadDelay (n * 200000)) >> return n
921compose :: (IsStream t, Semigroup (t IO Int))
922 => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec
923compose t z srt = do
924 -- XXX these should get covered by the property tests
925 it "Compose mempty, mempty" $
926 tl (z <> z) `shouldReturn` ([] :: [Int])
927 it "Compose empty at the beginning" $
928 tl (z <> singleton 1) `shouldReturn` [1]
929 it "Compose empty at the end" $
930 tl (singleton 1 <> z) `shouldReturn` [1]
931 it "Compose two" $
932 srt <$> tl (singleton 0 <> singleton 1)
933 `shouldReturn` [0, 1]
934 it "Compose many" $
935 srt <$> tl (forEachWith (<>) [1..100] singleton)
936 `shouldReturn` [1..100]
938 -- These are not covered by the property tests
939 it "Compose three - empty in the middle" $
940 srt <$> tl (singleton 0 <> z <> singleton 1)
941 `shouldReturn` [0, 1]
942 it "Compose left associated" $
943 srt <$> tl (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3)
944 `shouldReturn` [0, 1, 2, 3]
945 it "Compose right associated" $
946 srt <$> tl (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3)))
947 `shouldReturn` [0, 1, 2, 3]
948 it "Compose hierarchical (multiple levels)" $
949 srt <$> tl (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))
950 <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))
951 `shouldReturn` [0..7]
952 where tl = S.toList . t
954composeAndComposeSimple
955 :: ( IsStream t1, Semigroup (t1 IO Int)
956 , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)
957#if __GLASGOW_HASKELL__ < 804
958 , Semigroup (t2 IO Int)
959#endif
960 )
961 => (t1 IO Int -> SerialT IO Int)
962 -> (t2 IO Int -> t2 IO Int)
963 -> [[Int]] -> Spec
964composeAndComposeSimple t1 t2 answer = do
965 let rfold = adapt . t2 . foldMapWith (<>) return
966 it "Compose right associated outer expr, right folded inner" $
967 (S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9]))
968 `shouldReturn` head answer
970 it "Compose left associated outer expr, right folded inner" $
971 (S.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9])
972 `shouldReturn` (answer !! 1)
974 let lfold xs = adapt $ t2 $ foldl (<>) mempty $ fmap return xs
975 it "Compose right associated outer expr, left folded inner" $
976 (S.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9]))
977 `shouldReturn` (answer !! 2)
979 it "Compose left associated outer expr, left folded inner" $
980 (S.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9])
981 `shouldReturn` (answer !! 3)
983loops
984 :: (IsStream t, Semigroup (t IO Int), Monad (t IO))
985 => (t IO Int -> t IO Int)
986 -> ([Int] -> [Int])
987 -> ([Int] -> [Int])
988 -> Spec
989loops t tsrt hsrt = do
990 it "Tail recursive loop" $ (tsrt <$> (S.toList . adapt) (loopTail 0))
991 `shouldReturn` [0..3]
993 it "Head recursive loop" $ (hsrt <$> (S.toList . adapt) (loopHead 0))
994 `shouldReturn` [0..3]
996 where
997 loopHead x = do
998 -- this print line is important for the test (causes a bind)
999 S.yieldM $ putStrLn "LoopHead..."
1000 t $ (if x < 3 then loopHead (x + 1) else nil) <> return x
1002 loopTail x = do
1003 -- this print line is important for the test (causes a bind)
1004 S.yieldM $ putStrLn "LoopTail..."
1005 t $ return x <> (if x < 3 then loopTail (x + 1) else nil)
1007bindAndComposeSimple
1008 :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))
1009 => (t1 IO Int -> SerialT IO Int)
1010 -> (t2 IO Int -> t2 IO Int)
1011 -> Spec
1012bindAndComposeSimple t1 t2 = do
1013 -- XXX need a bind in the body of forEachWith instead of a simple return
1014 it "Compose many (right fold) with bind" $
1015 (sort <$> (S.toList . t1)
1016 (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return))
1017 `shouldReturn` [1..10]
1019 it "Compose many (left fold) with bind" $
1020 let forL xs k = foldl (<>) nil $ fmap k xs
1021 in (sort <$> (S.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return))
1022 `shouldReturn` [1..10]
1024bindAndComposeHierarchy
1025 :: ( IsStream t1, Monad (t1 IO)
1026 , IsStream t2, Monad (t2 IO))
1027 => (t1 IO Int -> SerialT IO Int)
1028 -> (t2 IO Int -> t2 IO Int)
1029 -> ([t2 IO Int] -> t2 IO Int)
1030 -> Spec
1031bindAndComposeHierarchy t1 t2 g =
1032 it "Bind and compose nested" $
1033 (sort <$> (S.toList . t1) bindComposeNested)
1034 `shouldReturn` (sort (
1035 [12, 18]
1036 <> replicate 3 13
1037 <> replicate 3 17
1038 <> replicate 6 14
1039 <> replicate 6 16
1040 <> replicate 7 15) :: [Int])
1042 where
1044 -- bindComposeNested :: WAsyncT IO Int
1045 bindComposeNested =
1046 let c1 = tripleCompose (return 1) (return 2) (return 3)
1047 c2 = tripleCompose (return 4) (return 5) (return 6)
1048 c3 = tripleCompose (return 7) (return 8) (return 9)
1049 b = tripleBind c1 c2 c3
1050-- it seems to be causing a huge space leak in hspec so disabling this for now
1051-- c = tripleCompose b b b
1052-- m = tripleBind c c c
1053-- in m
1054 in b
1056 tripleCompose a b c = adapt . t2 $ g [a, b, c]
1057 tripleBind mx my mz =
1058 mx >>= \x -> my
1059 >>= \y -> mz
1060 >>= \z -> return (x + y + z)
1062mixedOps :: Spec
1063mixedOps =
1064 it "Compose many ops" $
1065 (sort <$> toListSerial composeMixed)
1066 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
1067 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
1068 ] :: [Int])
1069 where
1071 composeMixed :: SerialT IO Int
1072 composeMixed = do
1073 S.yieldM $ return ()
1074 S.yieldM $ putStr ""
1075 let x = 1
1076 let y = 2
1077 z <- do
1078 x1 <- wAsyncly $ return 1 <> return 2
1079 S.yieldM $ return ()
1080 S.yieldM $ putStr ""
1081 y1 <- asyncly $ return 1 <> return 2
1082 z1 <- do
1083 x11 <- return 1 <> return 2
1084 y11 <- asyncly $ return 1 <> return 2
1085 z11 <- wSerially $ return 1 <> return 2
1086 S.yieldM $ return ()
1087 S.yieldM $ putStr ""
1088 return (x11 + y11 + z11)
1089 return (x1 + y1 + z1)
1090 return (x + y + z)
1092mixedOpsAheadly :: Spec
1093mixedOpsAheadly =
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 <- aheadly $ return 1 <> return 2
1112 z1 <- do
1113 x11 <- return 1 <> return 2
1114 y11 <- aheadly $ return 1 <> return 2
1115 z11 <- parallely $ 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)