git.iko.soy/streamly
on ed0323c help sign in
streamly/test/Main.hs
804 lines 35 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE RankNTypes #-}
5module Main (main) where
7import Control.Concurrent (threadDelay)
8import Control.Exception (Exception, try)
9import Control.Monad.Catch (throwM, MonadThrow)
10import Control.Monad.Error.Class (throwError, MonadError)
11import Control.Monad.Trans.Except (runExceptT, ExceptT)
12import Data.Foldable (forM_, fold)
13import Data.List (sort)
14import Test.Hspec
16import Streamly
17import Streamly.Prelude ((.:), nil)
18import qualified Streamly.Prelude as A
20singleton :: IsStream t => a -> t m a
21singleton a = a .: nil
23toListSerial :: SerialT IO a -> IO [a]
24toListSerial = A.toList . serially
26toListInterleaved :: WSerialT IO a -> IO [a]
27toListInterleaved = A.toList . wSerially
29toListAsync :: AsyncT IO a -> IO [a]
30toListAsync = A.toList . asyncly
32toListParallel :: WAsyncT IO a -> IO [a]
33toListParallel = A.toList . wAsyncly
35main :: IO ()
36main = hspec $ do
37 describe "Runners" $ do
38 -- XXX move these to property tests
39 -- XXX use an IORef to store and check the side effects
40 it "simple serially" $
41 (runStream . serially) (return (0 :: Int)) `shouldReturn` ()
42 it "simple serially with IO" $
43 (runStream . serially) (A.once $ putStrLn "hello") `shouldReturn` ()
45 describe "Empty" $ do
46 it "Monoid - mempty" $
47 (toListSerial mempty) `shouldReturn` ([] :: [Int])
48 -- it "Alternative - empty" $
49 -- (toListSerial empty) `shouldReturn` ([] :: [Int])
50 -- it "MonadPlus - mzero" $
51 -- (toListSerial mzero) `shouldReturn` ([] :: [Int])
53 ---------------------------------------------------------------------------
54 -- Functor
55 ---------------------------------------------------------------------------
57 describe "Functor (fmap)" $ do
58 -- XXX we should do these through property tests by using a
59 -- construction via list fold construction method.
60 it "fmap on composed (<>)" $
61 (toListSerial $ fmap (+1) (return 1 <> return 2))
62 `shouldReturn` ([2,3] :: [Int])
64 it "fmap on composed (<>)" $
65 ((toListParallel $ fmap (+1) (return 1 <> return 2)) >>= return . sort)
66 `shouldReturn` ([2,3] :: [Int])
68 ---------------------------------------------------------------------------
69 -- Applicative
70 ---------------------------------------------------------------------------
72 describe "Applicative" $ do
73 -- XXX we should do these through property tests by using a
74 -- construction via list fold construction method.
75 it "Apply - serial composed first argument" $
76 (toListSerial $ (,) <$> (return 1 <> return 2) <*> (return 3))
77 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
79 it "Apply - serial composed second argument" $
80 (toListSerial $ (,) <$> (return 1) <*> (return 2 <> return 3))
81 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
83 it "Apply - parallel composed first argument" $
84 (toListParallel ((,) <$> (return 1 <> return 2) <*> (return 3)) >>= return . sort)
85 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
87 it "Apply - parallel composed second argument" $
88 (toListParallel ((,) <$> (return 1) <*> (return 2 <> return 3)) >>= return . sort)
89 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
91 ---------------------------------------------------------------------------
92 -- Semigroup/Monoidal Composition strict ordering checks
93 ---------------------------------------------------------------------------
95 -- test both (<>) and mappend to make sure we are using correct instance
96 -- for Monoid that is using the right version of semigroup. Instance
97 -- deriving can cause us to pick wrong instances sometimes.
99 describe "Serial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)
100 describe "Serial interleaved mappend ordering check" $ interleaveCheck wSerially mappend
102 describe "Parallel interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)
103 describe "Parallel interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend
105 -- describe "Parallel (<>) ordering check" $ interleaveCheck parallely (<>)
106 -- describe "Parallel mappend ordering check" $ interleaveCheck parallely mappend
108 describe "Async (<>) time order check" $ parallelCheck asyncly (<>)
109 describe "Async mappend time order check" $ parallelCheck asyncly mappend
110 describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>)
111 describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend
113 ---------------------------------------------------------------------------
114 -- Monoidal Compositions, multiset equality checks
115 ---------------------------------------------------------------------------
117 describe "Serial Composition" $ compose serially mempty id
118 describe "Ahead Composition" $ compose aheadly mempty id
119 describe "WSerial Composition" $ compose wSerially mempty sort
120 describe "Async Composition" $ compose asyncly mempty sort
121 describe "WAsync Composition" $ compose wAsyncly mempty sort
122 describe "Parallel Composition" $ compose parallely mempty sort
123 describe "Semigroup Composition for ZipSerial" $ compose zipSerially mempty id
124 describe "Semigroup Composition for ZipAsync" $ compose zipAsyncly mempty id
125 -- XXX need to check alternative compositions as well
127 ---------------------------------------------------------------------------
128 -- TBD Monoidal composition combinations
129 ---------------------------------------------------------------------------
131 -- TBD need more such combinations to be tested.
132 describe "serial <> and serial <>" $ composeAndComposeSimple serially serially (cycle [[1 .. 9]])
133 describe "ahead <> and ahead <>" $ composeAndComposeSimple aheadly aheadly (cycle [[1 .. 9]])
134 describe "ahead <> and serial <>" $ composeAndComposeSimple aheadly serially (cycle [[1 .. 9]])
135 describe "serial <> and ahead <>" $ composeAndComposeSimple serially aheadly (cycle [[1 .. 9]])
137 describe "<> and <=>" $ composeAndComposeSimple
138 serially
139 wSerially
140 ([ [1 .. 9]
141 , [1 .. 9]
142 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
143 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
144 ])
146 describe "<=> and <=>" $ composeAndComposeSimple
147 wSerially
148 wSerially
149 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
150 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
151 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
152 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
153 ])
155 describe "<=> and <>" $ composeAndComposeSimple
156 wSerially
157 serially
158 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
159 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
160 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
161 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
162 ])
164 describe "Nested parallel and serial compositions" $ do
165 let t = timed
166 p = wAsyncly
167 s = serially
168 {-
169 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
170 -- because of parallelism of [8,0] and [8,0].
171 it "Nest <|>, <>, <|> (1)" $
172 let t = timed
173 in toListSerial (
174 ((t 8 <|> t 4) <> (t 2 <|> t 0))
175 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
176 `shouldReturn` ([4,4,8,8,0,0,2,2])
177 -}
178 it "Nest <|>, <>, <|> (2)" $
179 (A.toList . wAsyncly) (
180 s (p (t 4 <> t 8) <> p (t 1 <> t 2))
181 <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))
182 `shouldReturn` ([4,4,8,8,1,1,2,2])
183 -- FIXME: These two keep failing intermittently on Mac OS X
184 -- Need to examine and fix the tests.
185 {-
186 it "Nest <|>, <=>, <|> (1)" $
187 let t = timed
188 in toListSerial (
189 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
190 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
191 `shouldReturn` ([4,4,0,0,8,2,9,2])
192 it "Nest <|>, <=>, <|> (2)" $
193 let t = timed
194 in toListSerial (
195 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
196 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
197 `shouldReturn` ([4,4,1,1,8,2,9,2])
198 -}
199 it "Nest <|>, <|>, <|>" $
200 (A.toList . wAsyncly) (
201 ((t 4 <> t 8) <> (t 0 <> t 2))
202 <> ((t 4 <> t 8) <> (t 0 <> t 2)))
203 `shouldReturn` ([0,0,2,2,4,4,8,8])
205 ---------------------------------------------------------------------------
206 -- Monoidal composition recursion loops
207 ---------------------------------------------------------------------------
209 describe "Serial loops" $ loops serially id reverse
210 describe "Ahead loops" $ loops aheadly id reverse
211 describe "Async parallel loops" $ loops asyncly sort sort
212 describe "WAsync loops" $ loops wAsyncly sort sort
213 describe "parallel loops" $ loops parallely sort sort
215 ---------------------------------------------------------------------------
216 -- Bind and monoidal composition combinations
217 ---------------------------------------------------------------------------
219 describe "Bind and compose Stream 1" $ bindAndComposeSimple serially serially
220 describe "Bind and compose Stream 2" $ bindAndComposeSimple serially wSerially
221 describe "Bind and compose Stream 3" $ bindAndComposeSimple serially asyncly
222 describe "Bind and compose Stream 4" $ bindAndComposeSimple serially wAsyncly
223 describe "Bind and compose Stream 5" $ bindAndComposeSimple serially parallely
224 describe "Bind and compose Stream 6" $ bindAndComposeSimple serially aheadly
226 describe "Bind and compose Ahead Stream 0" $ bindAndComposeSimple aheadly aheadly
227 describe "Bind and compose Ahead Stream 1" $ bindAndComposeSimple aheadly serially
228 describe "Bind and compose Ahead Stream 2" $ bindAndComposeSimple aheadly wSerially
229 describe "Bind and compose Ahead Stream 3" $ bindAndComposeSimple aheadly asyncly
230 describe "Bind and compose Ahead Stream 4" $ bindAndComposeSimple aheadly wAsyncly
231 describe "Bind and compose Ahead Stream 5" $ bindAndComposeSimple aheadly parallely
233 describe "Bind and compose Costream 1" $ bindAndComposeSimple wSerially serially
234 describe "Bind and compose Costream 2" $ bindAndComposeSimple wSerially wSerially
235 describe "Bind and compose Costream 3" $ bindAndComposeSimple wSerially asyncly
236 describe "Bind and compose Costream 4" $ bindAndComposeSimple wSerially wAsyncly
237 describe "Bind and compose Costream 5" $ bindAndComposeSimple wSerially parallely
238 describe "Bind and compose Costream 6" $ bindAndComposeSimple wSerially aheadly
240 describe "Bind and compose Async 1" $ bindAndComposeSimple asyncly serially
241 describe "Bind and compose Async 2" $ bindAndComposeSimple asyncly wSerially
242 describe "Bind and compose Async 3" $ bindAndComposeSimple asyncly asyncly
243 describe "Bind and compose Async 4" $ bindAndComposeSimple asyncly wAsyncly
244 describe "Bind and compose Async 5" $ bindAndComposeSimple asyncly parallely
245 describe "Bind and compose Async 6" $ bindAndComposeSimple asyncly aheadly
247 describe "Bind and compose WAsync 1" $ bindAndComposeSimple wAsyncly serially
248 describe "Bind and compose WAsync 2" $ bindAndComposeSimple wAsyncly wSerially
249 describe "Bind and compose WAsync 3" $ bindAndComposeSimple wAsyncly asyncly
250 describe "Bind and compose WAsync 4" $ bindAndComposeSimple wAsyncly wAsyncly
251 describe "Bind and compose WAsync 5" $ bindAndComposeSimple wAsyncly parallely
252 describe "Bind and compose WAsync 6" $ bindAndComposeSimple wAsyncly aheadly
254 describe "Bind and compose Parallel 1" $ bindAndComposeSimple parallely serially
255 describe "Bind and compose Parallel 2" $ bindAndComposeSimple parallely wSerially
256 describe "Bind and compose Parallel 3" $ bindAndComposeSimple parallely asyncly
257 describe "Bind and compose Parallel 4" $ bindAndComposeSimple parallely wAsyncly
258 describe "Bind and compose Parallel 5" $ bindAndComposeSimple parallely parallely
259 describe "Bind and compose Parallel 6" $ bindAndComposeSimple parallely aheadly
261 let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int
262 fldr = foldr (<>) nil
263 fldl = foldl (<>) nil
265 forM_ [fldr, fldl] $ \k ->
266 describe "Bind and compose" $ bindAndComposeHierarchy serially serially k
267 forM_ [fldr, fldl] $ \k ->
268 describe "Bind and compose" $ bindAndComposeHierarchy serially wSerially k
269 forM_ [fldr, fldl] $ \k ->
270 describe "Bind and compose" $ bindAndComposeHierarchy serially asyncly k
271 forM_ [fldr, fldl] $ \k ->
272 describe "Bind and compose" $ bindAndComposeHierarchy serially wAsyncly k
273 forM_ [fldr, fldl] $ \k ->
274 describe "Bind and compose" $ bindAndComposeHierarchy serially parallely k
275 forM_ [fldr, fldl] $ \k ->
276 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy serially aheadly k
278 forM_ [fldr, fldl] $ \k ->
279 describe "Bind and compose aheadly serially" $ bindAndComposeHierarchy aheadly serially k
280 forM_ [fldr, fldl] $ \k ->
281 describe "Bind and compose aheadly wSerially" $ bindAndComposeHierarchy aheadly wSerially k
282 forM_ [fldr, fldl] $ \k ->
283 describe "Bind and compose aheadly asyncly" $ bindAndComposeHierarchy aheadly asyncly k
284 forM_ [fldr, fldl] $ \k ->
285 describe "Bind and compose aheadly wAsyncly" $ bindAndComposeHierarchy aheadly wAsyncly k
286 forM_ [fldr, fldl] $ \k ->
287 describe "Bind and compose aheadly parallely" $ bindAndComposeHierarchy aheadly parallely k
288 forM_ [fldr, fldl] $ \k ->
289 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy aheadly aheadly k
291 forM_ [fldr, fldl] $ \k ->
292 describe "Bind and compose" $ bindAndComposeHierarchy wSerially serially k
293 forM_ [fldr, fldl] $ \k ->
294 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wSerially k
295 forM_ [fldr, fldl] $ \k ->
296 describe "Bind and compose" $ bindAndComposeHierarchy wSerially asyncly k
297 forM_ [fldr, fldl] $ \k ->
298 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wAsyncly k
299 forM_ [fldr, fldl] $ \k ->
300 describe "Bind and compose" $ bindAndComposeHierarchy wSerially parallely k
301 forM_ [fldr, fldl] $ \k ->
302 describe "Bind and compose wserially aheadly" $ bindAndComposeHierarchy wSerially aheadly k
304 forM_ [fldr, fldl] $ \k ->
305 describe "Bind and compose" $ bindAndComposeHierarchy asyncly serially k
306 forM_ [fldr, fldl] $ \k ->
307 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wSerially k
308 forM_ [fldr, fldl] $ \k ->
309 describe "Bind and compose" $ bindAndComposeHierarchy asyncly asyncly k
310 forM_ [fldr, fldl] $ \k ->
311 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wAsyncly k
312 forM_ [fldr, fldl] $ \k ->
313 describe "Bind and compose" $ bindAndComposeHierarchy asyncly parallely k
314 forM_ [fldr, fldl] $ \k ->
315 describe "Bind and compose asyncly aheadly" $ bindAndComposeHierarchy asyncly aheadly k
317 forM_ [fldr, fldl] $ \k ->
318 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly serially k
319 forM_ [fldr, fldl] $ \k ->
320 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wSerially k
321 forM_ [fldr, fldl] $ \k ->
322 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly asyncly k
323 forM_ [fldr, fldl] $ \k ->
324 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wAsyncly k
325 forM_ [fldr, fldl] $ \k ->
326 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly parallely k
327 forM_ [fldr, fldl] $ \k ->
328 describe "Bind and compose wAsyncly aheadly" $ bindAndComposeHierarchy wAsyncly aheadly k
330 forM_ [fldr, fldl] $ \k ->
331 describe "Bind and compose" $ bindAndComposeHierarchy parallely serially k
332 forM_ [fldr, fldl] $ \k ->
333 describe "Bind and compose" $ bindAndComposeHierarchy parallely wSerially k
334 forM_ [fldr, fldl] $ \k ->
335 describe "Bind and compose" $ bindAndComposeHierarchy parallely asyncly k
336 forM_ [fldr, fldl] $ \k ->
337 describe "Bind and compose" $ bindAndComposeHierarchy parallely wAsyncly k
338 forM_ [fldr, fldl] $ \k ->
339 describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k
340 forM_ [fldr, fldl] $ \k ->
341 describe "Bind and compose parallely aheadly" $ bindAndComposeHierarchy parallely aheadly k
343 -- Nest two lists using different styles of product compositions
344 it "Nests two streams using monadic serial composition" nestTwoSerial
345 it "Nests two streams using monadic ahead composition" nestTwoAhead
346 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
347 it "Nests two streams using monadic Async composition" nestTwoAsync
348 it "Nests two streams using monadic WAsync composition" nestTwoWAsync
349 it "Nests two streams using monadic parallel composition" nestTwoParallel
351 it "Nests two streams using applicative serial composition" nestTwoSerialApp
352 it "Nests two streams using applicative ahead composition" nestTwoAheadApp
353 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
354 it "Nests two streams using applicative Async composition" nestTwoAsyncApp
355 it "Nests two streams using applicative WAsync composition" nestTwoWAsyncApp
356 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
358 ---------------------------------------------------------------------------
359 -- TBD Bind and Bind combinations
360 ---------------------------------------------------------------------------
362 -- TBD combine all binds and all compose in one example
363 describe "Miscellaneous combined examples" mixedOps
364 describe "Miscellaneous combined examples aheadly" mixedOpsAheadly
365 describe "Simple MonadError and MonadThrow" simpleMonadError
367 {-
368 describe "Composed MonadError serially" $ composeWithMonadError serially
369 describe "Composed MonadError wSerially" $ composeWithMonadError wSerially
370 describe "Composed MonadError asyncly" $ composeWithMonadError asyncly
371 describe "Composed MonadError wAsyncly" $ composeWithMonadError wAsyncly
372 -}
374 describe "Composed MonadThrow serially" $ composeWithMonadThrow serially
375 describe "Composed MonadThrow wSerially" $ composeWithMonadThrow wSerially
376 describe "Composed MonadThrow asyncly" $ composeWithMonadThrow asyncly
377 describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow wAsyncly
378 describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely
379 describe "Composed MonadThrow aheadly" $ composeWithMonadThrow aheadly
381 it "asyncly crosses thread limit (2000 threads)" $
382 runStream (asyncly $ fold $
383 replicate 2000 $ A.once $ threadDelay 1000000)
384 `shouldReturn` ()
386 it "aheadly crosses thread limit (4000 threads)" $
387 runStream (aheadly $ fold $
388 replicate 4000 $ A.once $ threadDelay 1000000)
389 `shouldReturn` ()
391-- XXX need to test that we have promptly cleaned up everything after the error
392-- XXX We can also check the output that we are expected to get before the
393-- error occurs.
395data ExampleException = ExampleException String deriving (Eq, Show)
397instance Exception ExampleException
399simpleMonadError :: Spec
400simpleMonadError = do
401{-
402 it "simple runExceptT" $ do
403 (runExceptT $ runStream $ return ())
404 `shouldReturn` (Right () :: Either String ())
405 it "simple runExceptT with error" $ do
406 (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"
407 -}
408 it "simple try" $ do
409 (try $ runStream $ return ())
410 `shouldReturn` (Right () :: Either ExampleException ())
411 it "simple try with throw error" $ do
412 (try $ runStream $ throwM $ ExampleException "E")
413 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
415composeWithMonadThrow
416 :: ( IsStream t
417 , Semigroup (t IO Int)
418 , MonadThrow (t IO)
419 )
420 => (t IO Int -> SerialT IO Int) -> Spec
421composeWithMonadThrow t = do
422 it "Compose throwM, nil" $
423 (try $ tl (throwM (ExampleException "E") <> A.nil))
424 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
425 it "Compose nil, throwM" $
426 (try $ tl (A.nil <> throwM (ExampleException "E")))
427 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
428 oneLevelNestedSum "serially" serially
429 oneLevelNestedSum "wSerially" wSerially
430 oneLevelNestedSum "asyncly" asyncly
431 oneLevelNestedSum "wAsyncly" wAsyncly
432 -- XXX add two level nesting
434 oneLevelNestedProduct "serially" serially
435 oneLevelNestedProduct "wSerially" wSerially
436 oneLevelNestedProduct "asyncly" asyncly
437 oneLevelNestedProduct "wAsyncly" wAsyncly
439 where
440 tl = A.toList . t
441 oneLevelNestedSum desc t1 =
442 it ("One level nested sum " ++ desc) $ do
443 let nested = (A.fromFoldable [1..10] <> throwM (ExampleException "E")
444 <> A.fromFoldable [1..10])
445 (try $ tl (A.nil <> t1 nested <> A.fromFoldable [1..10]))
446 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
448 oneLevelNestedProduct desc t1 =
449 it ("One level nested product" ++ desc) $ do
450 let s1 = t $ foldMapWith (<>) return [1..4]
451 s2 = t1 $ foldMapWith (<>) return [5..8]
452 try $ tl (do
453 x <- adapt s1
454 y <- s2
455 if (x + y > 10)
456 then throwM (ExampleException "E")
457 else return (x + y)
458 )
459 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
461_composeWithMonadError
462 :: ( IsStream t
463 , Semigroup (t (ExceptT String IO) Int)
464 , MonadError String (t (ExceptT String IO))
465 )
466 => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec
467_composeWithMonadError t = do
468 let tl = A.toList . t
469 it "Compose throwError, nil" $
470 (runExceptT $ tl (throwError "E" <> A.nil)) `shouldReturn` Left "E"
471 it "Compose nil, error" $
472 (runExceptT $ tl (A.nil <> throwError "E")) `shouldReturn` Left "E"
474nestTwoSerial :: Expectation
475nestTwoSerial =
476 let s1 = foldMapWith (<>) return [1..4]
477 s2 = foldMapWith (<>) return [5..8]
478 in toListSerial (do
479 x <- s1
480 y <- s2
481 return (x + y)
482 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
484nestTwoAhead :: Expectation
485nestTwoAhead =
486 let s1 = foldMapWith (<>) return [1..4]
487 s2 = foldMapWith (<>) return [5..8]
488 in (A.toList . aheadly) (do
489 x <- s1
490 y <- s2
491 return (x + y)
492 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
494nestTwoSerialApp :: Expectation
495nestTwoSerialApp =
496 let s1 = foldMapWith (<>) return [1..4]
497 s2 = foldMapWith (<>) return [5..8]
498 in toListSerial ((+) <$> s1 <*> s2)
499 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
501nestTwoAheadApp :: Expectation
502nestTwoAheadApp =
503 let s1 = foldMapWith (<>) return [1..4]
504 s2 = foldMapWith (<>) return [5..8]
505 in (A.toList . aheadly) ((+) <$> s1 <*> s2)
506 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
508nestTwoInterleaved :: Expectation
509nestTwoInterleaved =
510 let s1 = foldMapWith (<>) return [1..4]
511 s2 = foldMapWith (<>) return [5..8]
512 in toListInterleaved (do
513 x <- s1
514 y <- s2
515 return (x + y)
516 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
518nestTwoInterleavedApp :: Expectation
519nestTwoInterleavedApp =
520 let s1 = foldMapWith (<>) return [1..4]
521 s2 = foldMapWith (<>) return [5..8]
522 in toListInterleaved ((+) <$> s1 <*> s2)
523 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
525nestTwoAsync :: Expectation
526nestTwoAsync =
527 let s1 = foldMapWith (<>) return [1..4]
528 s2 = foldMapWith (<>) return [5..8]
529 in (toListAsync (do
530 x <- s1
531 y <- s2
532 return (x + y)
533 ) >>= return . sort)
534 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
536nestTwoAsyncApp :: Expectation
537nestTwoAsyncApp =
538 let s1 = foldMapWith (<>) return [1..4]
539 s2 = foldMapWith (<>) return [5..8]
540 in (toListAsync ((+) <$> s1 <*> s2) >>= return . sort)
541 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
543nestTwoWAsync :: Expectation
544nestTwoWAsync =
545 let s1 = foldMapWith (<>) return [1..4]
546 s2 = foldMapWith (<>) return [5..8]
547 in ((A.toList . wAsyncly) (do
548 x <- s1
549 y <- s2
550 return (x + y)
551 ) >>= return . sort)
552 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
554nestTwoParallel :: Expectation
555nestTwoParallel =
556 let s1 = foldMapWith (<>) return [1..4]
557 s2 = foldMapWith (<>) return [5..8]
558 in ((A.toList . parallely) (do
559 x <- s1
560 y <- s2
561 return (x + y)
562 ) >>= return . sort)
563 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
565nestTwoWAsyncApp :: Expectation
566nestTwoWAsyncApp =
567 let s1 = foldMapWith (<>) return [1..4]
568 s2 = foldMapWith (<>) return [5..8]
569 in ((A.toList . wAsyncly) ((+) <$> s1 <*> s2) >>= return . sort)
570 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
572nestTwoParallelApp :: Expectation
573nestTwoParallelApp =
574 let s1 = foldMapWith (<>) return [1..4]
575 s2 = foldMapWith (<>) return [5..8]
576 in ((A.toList . parallely) ((+) <$> s1 <*> s2) >>= return . sort)
577 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
579timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int
580timed x = A.once (threadDelay (x * 100000)) >> return x
582interleaveCheck :: IsStream t
583 => (t IO Int -> SerialT IO Int)
584 -> (t IO Int -> t IO Int -> t IO Int)
585 -> Spec
586interleaveCheck t f =
587 it "Interleave four" $
588 (A.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))
589 `shouldReturn` ([0, 100, 1, 101])
591parallelCheck :: (IsStream t, Monad (t IO))
592 => (t IO Int -> SerialT IO Int)
593 -> (t IO Int -> t IO Int -> t IO Int)
594 -> Spec
595parallelCheck t f = do
596 it "Parallel ordering left associated" $
597 (A.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)
598 `shouldReturn` ([1..4])
600 it "Parallel ordering right associated" $
601 (A.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
602 `shouldReturn` ([1..4])
604 where event n = (A.once $ threadDelay (n * 100000)) >> (return n)
606compose :: (IsStream t, Semigroup (t IO Int))
607 => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec
608compose t z srt = do
609 -- XXX these should get covered by the property tests
610 it "Compose mempty, mempty" $
611 (tl (z <> z)) `shouldReturn` ([] :: [Int])
612 it "Compose empty at the beginning" $
613 (tl $ (z <> singleton 1)) `shouldReturn` [1]
614 it "Compose empty at the end" $
615 (tl $ (singleton 1 <> z)) `shouldReturn` [1]
616 it "Compose two" $
617 (tl (singleton 0 <> singleton 1) >>= return . srt)
618 `shouldReturn` [0, 1]
619 it "Compose many" $
620 ((tl $ forEachWith (<>) [1..100] singleton) >>= return . srt)
621 `shouldReturn` [1..100]
623 -- These are not covered by the property tests
624 it "Compose three - empty in the middle" $
625 ((tl $ (singleton 0 <> z <> singleton 1)) >>= return . srt)
626 `shouldReturn` [0, 1]
627 it "Compose left associated" $
628 ((tl $ (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3))
629 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
630 it "Compose right associated" $
631 ((tl $ (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3))))
632 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
633 it "Compose hierarchical (multiple levels)" $
634 ((tl $ (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))
635 <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))
636 ) >>= return . srt) `shouldReturn` [0..7]
637 where tl = A.toList . t
639composeAndComposeSimple
640 :: ( IsStream t1, Semigroup (t1 IO Int)
641 , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)
642#if __GLASGOW_HASKELL__ < 804
643 , Semigroup (t2 IO Int)
644#endif
645 )
646 => (t1 IO Int -> SerialT IO Int)
647 -> (t2 IO Int -> t2 IO Int)
648 -> [[Int]] -> Spec
649composeAndComposeSimple t1 t2 answer = do
650 let rfold = adapt . t2 . foldMapWith (<>) return
651 it "Compose right associated outer expr, right folded inner" $
652 ((A.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9])))
653 `shouldReturn` (answer !! 0)
655 it "Compose left associated outer expr, right folded inner" $
656 ((A.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9]))
657 `shouldReturn` (answer !! 1)
659 let lfold xs = adapt $ t2 $ foldl (<>) mempty $ map return xs
660 it "Compose right associated outer expr, left folded inner" $
661 ((A.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9])))
662 `shouldReturn` (answer !! 2)
664 it "Compose left associated outer expr, left folded inner" $
665 ((A.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9]))
666 `shouldReturn` (answer !! 3)
668loops
669 :: (IsStream t, Semigroup (t IO Int), Monad (t IO))
670 => (t IO Int -> t IO Int)
671 -> ([Int] -> [Int])
672 -> ([Int] -> [Int])
673 -> Spec
674loops t tsrt hsrt = do
675 it "Tail recursive loop" $ ((A.toList . adapt) (loopTail 0) >>= return . tsrt)
676 `shouldReturn` [0..3]
678 it "Head recursive loop" $ ((A.toList . adapt) (loopHead 0) >>= return . hsrt)
679 `shouldReturn` [0..3]
681 where
682 loopHead x = do
683 -- this print line is important for the test (causes a bind)
684 A.once $ putStrLn "LoopHead..."
685 t $ (if x < 3 then loopHead (x + 1) else nil) <> return x
687 loopTail x = do
688 -- this print line is important for the test (causes a bind)
689 A.once $ putStrLn "LoopTail..."
690 t $ return x <> (if x < 3 then loopTail (x + 1) else nil)
692bindAndComposeSimple
693 :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))
694 => (t1 IO Int -> SerialT IO Int)
695 -> (t2 IO Int -> t2 IO Int)
696 -> Spec
697bindAndComposeSimple t1 t2 = do
698 -- XXX need a bind in the body of forEachWith instead of a simple return
699 it "Compose many (right fold) with bind" $
700 ((A.toList . t1) (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return)
701 >>= return . sort) `shouldReturn` [1..10]
703 it "Compose many (left fold) with bind" $
704 let forL xs k = foldl (<>) nil $ map k xs
705 in ((A.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return)
706 >>= return . sort) `shouldReturn` [1..10]
708bindAndComposeHierarchy
709 :: ( IsStream t1, Monad (t1 IO)
710 , IsStream t2, Monad (t2 IO))
711 => (t1 IO Int -> SerialT IO Int)
712 -> (t2 IO Int -> t2 IO Int)
713 -> ([t2 IO Int] -> t2 IO Int)
714 -> Spec
715bindAndComposeHierarchy t1 t2 g = do
716 it "Bind and compose nested" $
717 ((A.toList . t1) bindComposeNested >>= return . sort)
718 `shouldReturn` (sort (
719 [12, 18]
720 ++ replicate 3 13
721 ++ replicate 3 17
722 ++ replicate 6 14
723 ++ replicate 6 16
724 ++ replicate 7 15) :: [Int])
726 where
728 -- bindComposeNested :: WAsyncT IO Int
729 bindComposeNested =
730 let c1 = tripleCompose (return 1) (return 2) (return 3)
731 c2 = tripleCompose (return 4) (return 5) (return 6)
732 c3 = tripleCompose (return 7) (return 8) (return 9)
733 b = tripleBind c1 c2 c3
734-- it seems to be causing a huge space leak in hspec so disabling this for now
735-- c = tripleCompose b b b
736-- m = tripleBind c c c
737-- in m
738 in b
740 tripleCompose a b c = adapt . t2 $ g [a, b, c]
741 tripleBind mx my mz =
742 mx >>= \x -> my
743 >>= \y -> mz
744 >>= \z -> return (x + y + z)
746mixedOps :: Spec
747mixedOps = do
748 it "Compose many ops" $
749 (toListSerial composeMixed >>= return . sort)
750 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
751 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
752 ] :: [Int])
753 where
755 composeMixed :: SerialT IO Int
756 composeMixed = do
757 A.once $ return ()
758 A.once $ putStr ""
759 x <- return 1
760 y <- return 2
761 z <- do
762 x1 <- wAsyncly $ return 1 <> return 2
763 A.once $ return ()
764 A.once $ putStr ""
765 y1 <- asyncly $ return 1 <> return 2
766 z1 <- do
767 x11 <- return 1 <> return 2
768 y11 <- asyncly $ return 1 <> return 2
769 z11 <- wSerially $ return 1 <> return 2
770 A.once $ return ()
771 A.once $ putStr ""
772 return (x11 + y11 + z11)
773 return (x1 + y1 + z1)
774 return (x + y + z)
776mixedOpsAheadly :: Spec
777mixedOpsAheadly = do
778 it "Compose many ops" $
779 (toListSerial composeMixed >>= return . sort)
780 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
781 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
782 ] :: [Int])
783 where
785 composeMixed :: SerialT IO Int
786 composeMixed = do
787 A.once $ return ()
788 A.once $ putStr ""
789 x <- return 1
790 y <- return 2
791 z <- do
792 x1 <- wAsyncly $ return 1 <> return 2
793 A.once $ return ()
794 A.once $ putStr ""
795 y1 <- aheadly $ return 1 <> return 2
796 z1 <- do
797 x11 <- return 1 <> return 2
798 y11 <- aheadly $ return 1 <> return 2
799 z11 <- parallely $ return 1 <> return 2
800 A.once $ return ()
801 A.once $ putStr ""
802 return (x11 + y11 + z11)
803 return (x1 + y1 + z1)
804 return (x + y + z)