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