git.iko.soy/streamly
on 09c955e help sign in
streamly/test/Main.hs
817 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 S
20singleton :: IsStream t => a -> t m a
21singleton a = a .: nil
23toListSerial :: SerialT IO a -> IO [a]
24toListSerial = S.toList . serially
26toListInterleaved :: WSerialT IO a -> IO [a]
27toListInterleaved = S.toList . wSerially
29toListAsync :: AsyncT IO a -> IO [a]
30toListAsync = S.toList . asyncly
32toListParallel :: WAsyncT IO a -> IO [a]
33toListParallel = S.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) (S.yieldM $ 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 "WSerial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)
100 describe "WSerial interleaved mappend ordering check" $ interleaveCheck wSerially mappend
102 -- describe "WAsync interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)
103 -- describe "WAsync interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend
105 describe "Async (<>) time order check" $ parallelCheck asyncly (<>)
106 describe "Async mappend time order check" $ parallelCheck asyncly mappend
108 -- XXX this keeps failing intermittently, need to investigate
109 -- describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>)
110 -- describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend
112 describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)
113 describe "Parallel mappend time order check" $ parallelCheck parallely mappend
115 ---------------------------------------------------------------------------
116 -- Monoidal Compositions, multiset equality checks
117 ---------------------------------------------------------------------------
119 describe "Serial Composition" $ compose serially mempty id
120 describe "Ahead Composition" $ compose aheadly mempty id
121 describe "WSerial Composition" $ compose wSerially mempty sort
122 describe "Async Composition" $ compose asyncly mempty sort
123 describe "WAsync Composition" $ compose wAsyncly mempty sort
124 describe "Parallel Composition" $ compose parallely mempty sort
125 describe "Semigroup Composition for ZipSerial" $ compose zipSerially mempty id
126 describe "Semigroup Composition for ZipAsync" $ compose zipAsyncly mempty id
127 -- XXX need to check alternative compositions as well
129 ---------------------------------------------------------------------------
130 -- TBD Monoidal composition combinations
131 ---------------------------------------------------------------------------
133 -- TBD need more such combinations to be tested.
134 describe "serial <> and serial <>" $ composeAndComposeSimple serially serially (cycle [[1 .. 9]])
135 describe "ahead <> and ahead <>" $ composeAndComposeSimple aheadly aheadly (cycle [[1 .. 9]])
136 describe "ahead <> and serial <>" $ composeAndComposeSimple aheadly serially (cycle [[1 .. 9]])
137 describe "serial <> and ahead <>" $ composeAndComposeSimple serially aheadly (cycle [[1 .. 9]])
139 describe "<> and <=>" $ composeAndComposeSimple
140 serially
141 wSerially
142 ([ [1 .. 9]
143 , [1 .. 9]
144 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
145 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
146 ])
148 describe "<=> and <=>" $ composeAndComposeSimple
149 wSerially
150 wSerially
151 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
152 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
153 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
154 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
155 ])
157 describe "<=> and <>" $ composeAndComposeSimple
158 wSerially
159 serially
160 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
161 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
162 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
163 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
164 ])
166 describe "Nested parallel and serial compositions" $ do
167 let t = timed
168 p = wAsyncly
169 s = serially
170 {-
171 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
172 -- because of parallelism of [8,0] and [8,0].
173 it "Nest <|>, <>, <|> (1)" $
174 let t = timed
175 in toListSerial (
176 ((t 8 <|> t 4) <> (t 2 <|> t 0))
177 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
178 `shouldReturn` ([4,4,8,8,0,0,2,2])
179 -}
180 it "Nest <|>, <>, <|> (2)" $
181 (S.toList . wAsyncly) (
182 s (p (t 4 <> t 8) <> p (t 1 <> t 2))
183 <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))
184 `shouldReturn` ([4,4,8,8,1,1,2,2])
185 -- FIXME: These two keep failing intermittently on Mac OS X
186 -- Need to examine and fix the tests.
187 {-
188 it "Nest <|>, <=>, <|> (1)" $
189 let t = timed
190 in toListSerial (
191 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
192 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
193 `shouldReturn` ([4,4,0,0,8,2,9,2])
194 it "Nest <|>, <=>, <|> (2)" $
195 let t = timed
196 in toListSerial (
197 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
198 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
199 `shouldReturn` ([4,4,1,1,8,2,9,2])
200 -}
201 it "Nest <|>, <|>, <|>" $
202 (S.toList . wAsyncly) (
203 ((t 4 <> t 8) <> (t 0 <> t 2))
204 <> ((t 4 <> t 8) <> (t 0 <> t 2)))
205 `shouldReturn` ([0,0,2,2,4,4,8,8])
207 ---------------------------------------------------------------------------
208 -- Monoidal composition recursion loops
209 ---------------------------------------------------------------------------
211 describe "Serial loops" $ loops serially id reverse
212 describe "Ahead loops" $ loops aheadly id reverse
213 describe "Async parallel loops" $ loops asyncly sort sort
214 describe "WAsync loops" $ loops wAsyncly sort sort
215 describe "parallel loops" $ loops parallely sort sort
217 ---------------------------------------------------------------------------
218 -- Bind and monoidal composition combinations
219 ---------------------------------------------------------------------------
221 describe "Bind and compose Stream 1" $ bindAndComposeSimple serially serially
222 describe "Bind and compose Stream 2" $ bindAndComposeSimple serially wSerially
223 describe "Bind and compose Stream 3" $ bindAndComposeSimple serially asyncly
224 describe "Bind and compose Stream 4" $ bindAndComposeSimple serially wAsyncly
225 describe "Bind and compose Stream 5" $ bindAndComposeSimple serially parallely
226 describe "Bind and compose Stream 6" $ bindAndComposeSimple serially aheadly
228 describe "Bind and compose Ahead Stream 0" $ bindAndComposeSimple aheadly aheadly
229 describe "Bind and compose Ahead Stream 1" $ bindAndComposeSimple aheadly serially
230 describe "Bind and compose Ahead Stream 2" $ bindAndComposeSimple aheadly wSerially
231 describe "Bind and compose Ahead Stream 3" $ bindAndComposeSimple aheadly asyncly
232 describe "Bind and compose Ahead Stream 4" $ bindAndComposeSimple aheadly wAsyncly
233 describe "Bind and compose Ahead Stream 5" $ bindAndComposeSimple aheadly parallely
235 describe "Bind and compose Costream 1" $ bindAndComposeSimple wSerially serially
236 describe "Bind and compose Costream 2" $ bindAndComposeSimple wSerially wSerially
237 describe "Bind and compose Costream 3" $ bindAndComposeSimple wSerially asyncly
238 describe "Bind and compose Costream 4" $ bindAndComposeSimple wSerially wAsyncly
239 describe "Bind and compose Costream 5" $ bindAndComposeSimple wSerially parallely
240 describe "Bind and compose Costream 6" $ bindAndComposeSimple wSerially aheadly
242 describe "Bind and compose Async 1" $ bindAndComposeSimple asyncly serially
243 describe "Bind and compose Async 2" $ bindAndComposeSimple asyncly wSerially
244 describe "Bind and compose Async 3" $ bindAndComposeSimple asyncly asyncly
245 describe "Bind and compose Async 4" $ bindAndComposeSimple asyncly wAsyncly
246 describe "Bind and compose Async 5" $ bindAndComposeSimple asyncly parallely
247 describe "Bind and compose Async 6" $ bindAndComposeSimple asyncly aheadly
249 describe "Bind and compose WAsync 1" $ bindAndComposeSimple wAsyncly serially
250 describe "Bind and compose WAsync 2" $ bindAndComposeSimple wAsyncly wSerially
251 describe "Bind and compose WAsync 3" $ bindAndComposeSimple wAsyncly asyncly
252 describe "Bind and compose WAsync 4" $ bindAndComposeSimple wAsyncly wAsyncly
253 describe "Bind and compose WAsync 5" $ bindAndComposeSimple wAsyncly parallely
254 describe "Bind and compose WAsync 6" $ bindAndComposeSimple wAsyncly aheadly
256 describe "Bind and compose Parallel 1" $ bindAndComposeSimple parallely serially
257 describe "Bind and compose Parallel 2" $ bindAndComposeSimple parallely wSerially
258 describe "Bind and compose Parallel 3" $ bindAndComposeSimple parallely asyncly
259 describe "Bind and compose Parallel 4" $ bindAndComposeSimple parallely wAsyncly
260 describe "Bind and compose Parallel 5" $ bindAndComposeSimple parallely parallely
261 describe "Bind and compose Parallel 6" $ bindAndComposeSimple parallely aheadly
263 let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int
264 fldr = foldr (<>) nil
265 fldl = foldl (<>) nil
267 forM_ [fldr, fldl] $ \k ->
268 describe "Bind and compose" $ bindAndComposeHierarchy serially serially k
269 forM_ [fldr, fldl] $ \k ->
270 describe "Bind and compose" $ bindAndComposeHierarchy serially wSerially k
271 forM_ [fldr, fldl] $ \k ->
272 describe "Bind and compose" $ bindAndComposeHierarchy serially asyncly k
273 forM_ [fldr, fldl] $ \k ->
274 describe "Bind and compose" $ bindAndComposeHierarchy serially wAsyncly k
275 forM_ [fldr, fldl] $ \k ->
276 describe "Bind and compose" $ bindAndComposeHierarchy serially parallely k
277 forM_ [fldr, fldl] $ \k ->
278 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy serially aheadly k
280 forM_ [fldr, fldl] $ \k ->
281 describe "Bind and compose aheadly serially" $ bindAndComposeHierarchy aheadly serially k
282 forM_ [fldr, fldl] $ \k ->
283 describe "Bind and compose aheadly wSerially" $ bindAndComposeHierarchy aheadly wSerially k
284 forM_ [fldr, fldl] $ \k ->
285 describe "Bind and compose aheadly asyncly" $ bindAndComposeHierarchy aheadly asyncly k
286 forM_ [fldr, fldl] $ \k ->
287 describe "Bind and compose aheadly wAsyncly" $ bindAndComposeHierarchy aheadly wAsyncly k
288 forM_ [fldr, fldl] $ \k ->
289 describe "Bind and compose aheadly parallely" $ bindAndComposeHierarchy aheadly parallely k
290 forM_ [fldr, fldl] $ \k ->
291 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy aheadly aheadly k
293 forM_ [fldr, fldl] $ \k ->
294 describe "Bind and compose" $ bindAndComposeHierarchy wSerially serially k
295 forM_ [fldr, fldl] $ \k ->
296 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wSerially k
297 forM_ [fldr, fldl] $ \k ->
298 describe "Bind and compose" $ bindAndComposeHierarchy wSerially asyncly k
299 forM_ [fldr, fldl] $ \k ->
300 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wAsyncly k
301 forM_ [fldr, fldl] $ \k ->
302 describe "Bind and compose" $ bindAndComposeHierarchy wSerially parallely k
303 forM_ [fldr, fldl] $ \k ->
304 describe "Bind and compose wserially aheadly" $ bindAndComposeHierarchy wSerially aheadly k
306 forM_ [fldr, fldl] $ \k ->
307 describe "Bind and compose" $ bindAndComposeHierarchy asyncly serially k
308 forM_ [fldr, fldl] $ \k ->
309 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wSerially k
310 forM_ [fldr, fldl] $ \k ->
311 describe "Bind and compose" $ bindAndComposeHierarchy asyncly asyncly k
312 forM_ [fldr, fldl] $ \k ->
313 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wAsyncly k
314 forM_ [fldr, fldl] $ \k ->
315 describe "Bind and compose" $ bindAndComposeHierarchy asyncly parallely k
316 forM_ [fldr, fldl] $ \k ->
317 describe "Bind and compose asyncly aheadly" $ bindAndComposeHierarchy asyncly aheadly k
319 forM_ [fldr, fldl] $ \k ->
320 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly serially k
321 forM_ [fldr, fldl] $ \k ->
322 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wSerially k
323 forM_ [fldr, fldl] $ \k ->
324 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly asyncly k
325 forM_ [fldr, fldl] $ \k ->
326 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wAsyncly k
327 forM_ [fldr, fldl] $ \k ->
328 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly parallely k
329 forM_ [fldr, fldl] $ \k ->
330 describe "Bind and compose wAsyncly aheadly" $ bindAndComposeHierarchy wAsyncly aheadly k
332 forM_ [fldr, fldl] $ \k ->
333 describe "Bind and compose" $ bindAndComposeHierarchy parallely serially k
334 forM_ [fldr, fldl] $ \k ->
335 describe "Bind and compose" $ bindAndComposeHierarchy parallely wSerially k
336 forM_ [fldr, fldl] $ \k ->
337 describe "Bind and compose" $ bindAndComposeHierarchy parallely asyncly k
338 forM_ [fldr, fldl] $ \k ->
339 describe "Bind and compose" $ bindAndComposeHierarchy parallely wAsyncly k
340 forM_ [fldr, fldl] $ \k ->
341 describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k
342 forM_ [fldr, fldl] $ \k ->
343 describe "Bind and compose parallely aheadly" $ bindAndComposeHierarchy parallely aheadly k
345 -- Nest two lists using different styles of product compositions
346 it "Nests two streams using monadic serial composition" nestTwoSerial
347 it "Nests two streams using monadic ahead composition" nestTwoAhead
348 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
349 it "Nests two streams using monadic Async composition" nestTwoAsync
350 it "Nests two streams using monadic WAsync composition" nestTwoWAsync
351 it "Nests two streams using monadic parallel composition" nestTwoParallel
353 it "Nests two streams using applicative serial composition" nestTwoSerialApp
354 it "Nests two streams using applicative ahead composition" nestTwoAheadApp
355 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
356 it "Nests two streams using applicative Async composition" nestTwoAsyncApp
357 it "Nests two streams using applicative WAsync composition" nestTwoWAsyncApp
358 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
360 ---------------------------------------------------------------------------
361 -- TBD Bind and Bind combinations
362 ---------------------------------------------------------------------------
364 -- TBD combine all binds and all compose in one example
365 describe "Miscellaneous combined examples" mixedOps
366 describe "Miscellaneous combined examples aheadly" mixedOpsAheadly
367 describe "Simple MonadError and MonadThrow" simpleMonadError
369 {-
370 describe "Composed MonadError serially" $ composeWithMonadError serially
371 describe "Composed MonadError wSerially" $ composeWithMonadError wSerially
372 describe "Composed MonadError asyncly" $ composeWithMonadError asyncly
373 describe "Composed MonadError wAsyncly" $ composeWithMonadError wAsyncly
374 -}
376 describe "Composed MonadThrow serially" $ composeWithMonadThrow serially
377 describe "Composed MonadThrow wSerially" $ composeWithMonadThrow wSerially
378 describe "Composed MonadThrow asyncly" $ composeWithMonadThrow asyncly
379 describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow wAsyncly
380 describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely
381 describe "Composed MonadThrow aheadly" $ composeWithMonadThrow aheadly
383 describe "take on infinite concurrent stream" $ takeInfinite asyncly
384 describe "take on infinite concurrent stream" $ takeInfinite wAsyncly
385 describe "take on infinite concurrent stream" $ takeInfinite aheadly
387 it "asyncly crosses thread limit (2000 threads)" $
388 runStream (asyncly $ fold $
389 replicate 2000 $ S.yieldM $ threadDelay 1000000)
390 `shouldReturn` ()
392 it "aheadly crosses thread limit (4000 threads)" $
393 runStream (aheadly $ fold $
394 replicate 4000 $ S.yieldM $ threadDelay 1000000)
395 `shouldReturn` ()
397takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
398takeInfinite t = do
399 it "take 1" $
400 (runStream $ t $
401 S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))
402 `shouldReturn` ()
404-- XXX need to test that we have promptly cleaned up everything after the error
405-- XXX We can also check the output that we are expected to get before the
406-- error occurs.
408data ExampleException = ExampleException String deriving (Eq, Show)
410instance Exception ExampleException
412simpleMonadError :: Spec
413simpleMonadError = do
414{-
415 it "simple runExceptT" $ do
416 (runExceptT $ runStream $ return ())
417 `shouldReturn` (Right () :: Either String ())
418 it "simple runExceptT with error" $ do
419 (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"
420 -}
421 it "simple try" $ do
422 (try $ runStream $ return ())
423 `shouldReturn` (Right () :: Either ExampleException ())
424 it "simple try with throw error" $ do
425 (try $ runStream $ throwM $ ExampleException "E")
426 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
428composeWithMonadThrow
429 :: ( IsStream t
430 , Semigroup (t IO Int)
431 , MonadThrow (t IO)
432 )
433 => (t IO Int -> SerialT IO Int) -> Spec
434composeWithMonadThrow t = do
435 it "Compose throwM, nil" $
436 (try $ tl (throwM (ExampleException "E") <> S.nil))
437 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
438 it "Compose nil, throwM" $
439 (try $ tl (S.nil <> throwM (ExampleException "E")))
440 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
441 oneLevelNestedSum "serially" serially
442 oneLevelNestedSum "wSerially" wSerially
443 oneLevelNestedSum "asyncly" asyncly
444 oneLevelNestedSum "wAsyncly" wAsyncly
445 -- XXX add two level nesting
447 oneLevelNestedProduct "serially" serially
448 oneLevelNestedProduct "wSerially" wSerially
449 oneLevelNestedProduct "asyncly" asyncly
450 oneLevelNestedProduct "wAsyncly" wAsyncly
452 where
453 tl = S.toList . t
454 oneLevelNestedSum desc t1 =
455 it ("One level nested sum " ++ desc) $ do
456 let nested = (S.fromFoldable [1..10] <> throwM (ExampleException "E")
457 <> S.fromFoldable [1..10])
458 (try $ tl (S.nil <> t1 nested <> S.fromFoldable [1..10]))
459 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
461 oneLevelNestedProduct desc t1 =
462 it ("One level nested product" ++ desc) $ do
463 let s1 = t $ foldMapWith (<>) return [1..4]
464 s2 = t1 $ foldMapWith (<>) return [5..8]
465 try $ tl (do
466 x <- adapt s1
467 y <- s2
468 if (x + y > 10)
469 then throwM (ExampleException "E")
470 else return (x + y)
471 )
472 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
474_composeWithMonadError
475 :: ( IsStream t
476 , Semigroup (t (ExceptT String IO) Int)
477 , MonadError String (t (ExceptT String IO))
478 )
479 => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec
480_composeWithMonadError t = do
481 let tl = S.toList . t
482 it "Compose throwError, nil" $
483 (runExceptT $ tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"
484 it "Compose nil, error" $
485 (runExceptT $ tl (S.nil <> throwError "E")) `shouldReturn` Left "E"
487nestTwoSerial :: Expectation
488nestTwoSerial =
489 let s1 = foldMapWith (<>) return [1..4]
490 s2 = foldMapWith (<>) return [5..8]
491 in toListSerial (do
492 x <- s1
493 y <- s2
494 return (x + y)
495 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
497nestTwoAhead :: Expectation
498nestTwoAhead =
499 let s1 = foldMapWith (<>) return [1..4]
500 s2 = foldMapWith (<>) return [5..8]
501 in (S.toList . aheadly) (do
502 x <- s1
503 y <- s2
504 return (x + y)
505 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
507nestTwoSerialApp :: Expectation
508nestTwoSerialApp =
509 let s1 = foldMapWith (<>) return [1..4]
510 s2 = foldMapWith (<>) return [5..8]
511 in toListSerial ((+) <$> s1 <*> s2)
512 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
514nestTwoAheadApp :: Expectation
515nestTwoAheadApp =
516 let s1 = foldMapWith (<>) return [1..4]
517 s2 = foldMapWith (<>) return [5..8]
518 in (S.toList . aheadly) ((+) <$> s1 <*> s2)
519 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
521nestTwoInterleaved :: Expectation
522nestTwoInterleaved =
523 let s1 = foldMapWith (<>) return [1..4]
524 s2 = foldMapWith (<>) return [5..8]
525 in toListInterleaved (do
526 x <- s1
527 y <- s2
528 return (x + y)
529 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
531nestTwoInterleavedApp :: Expectation
532nestTwoInterleavedApp =
533 let s1 = foldMapWith (<>) return [1..4]
534 s2 = foldMapWith (<>) return [5..8]
535 in toListInterleaved ((+) <$> s1 <*> s2)
536 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
538nestTwoAsync :: Expectation
539nestTwoAsync =
540 let s1 = foldMapWith (<>) return [1..4]
541 s2 = foldMapWith (<>) return [5..8]
542 in (toListAsync (do
543 x <- s1
544 y <- s2
545 return (x + y)
546 ) >>= return . sort)
547 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
549nestTwoAsyncApp :: Expectation
550nestTwoAsyncApp =
551 let s1 = foldMapWith (<>) return [1..4]
552 s2 = foldMapWith (<>) return [5..8]
553 in (toListAsync ((+) <$> s1 <*> s2) >>= return . sort)
554 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
556nestTwoWAsync :: Expectation
557nestTwoWAsync =
558 let s1 = foldMapWith (<>) return [1..4]
559 s2 = foldMapWith (<>) return [5..8]
560 in ((S.toList . wAsyncly) (do
561 x <- s1
562 y <- s2
563 return (x + y)
564 ) >>= return . sort)
565 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
567nestTwoParallel :: Expectation
568nestTwoParallel =
569 let s1 = foldMapWith (<>) return [1..4]
570 s2 = foldMapWith (<>) return [5..8]
571 in ((S.toList . parallely) (do
572 x <- s1
573 y <- s2
574 return (x + y)
575 ) >>= return . sort)
576 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
578nestTwoWAsyncApp :: Expectation
579nestTwoWAsyncApp =
580 let s1 = foldMapWith (<>) return [1..4]
581 s2 = foldMapWith (<>) return [5..8]
582 in ((S.toList . wAsyncly) ((+) <$> s1 <*> s2) >>= return . sort)
583 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
585nestTwoParallelApp :: Expectation
586nestTwoParallelApp =
587 let s1 = foldMapWith (<>) return [1..4]
588 s2 = foldMapWith (<>) return [5..8]
589 in ((S.toList . parallely) ((+) <$> s1 <*> s2) >>= return . sort)
590 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
592timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int
593timed x = S.yieldM (threadDelay (x * 100000)) >> return x
595interleaveCheck :: IsStream t
596 => (t IO Int -> SerialT IO Int)
597 -> (t IO Int -> t IO Int -> t IO Int)
598 -> Spec
599interleaveCheck t f =
600 it "Interleave four" $
601 (S.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))
602 `shouldReturn` ([0, 100, 1, 101])
604parallelCheck :: (IsStream t, Monad (t IO))
605 => (t IO Int -> SerialT IO Int)
606 -> (t IO Int -> t IO Int -> t IO Int)
607 -> Spec
608parallelCheck t f = do
609 it "Parallel ordering left associated" $
610 (S.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)
611 `shouldReturn` ([1..4])
613 it "Parallel ordering right associated" $
614 (S.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
615 `shouldReturn` ([1..4])
617 where event n = (S.yieldM $ threadDelay (n * 200000)) >> (return n)
619compose :: (IsStream t, Semigroup (t IO Int))
620 => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec
621compose t z srt = do
622 -- XXX these should get covered by the property tests
623 it "Compose mempty, mempty" $
624 (tl (z <> z)) `shouldReturn` ([] :: [Int])
625 it "Compose empty at the beginning" $
626 (tl $ (z <> singleton 1)) `shouldReturn` [1]
627 it "Compose empty at the end" $
628 (tl $ (singleton 1 <> z)) `shouldReturn` [1]
629 it "Compose two" $
630 (tl (singleton 0 <> singleton 1) >>= return . srt)
631 `shouldReturn` [0, 1]
632 it "Compose many" $
633 ((tl $ forEachWith (<>) [1..100] singleton) >>= return . srt)
634 `shouldReturn` [1..100]
636 -- These are not covered by the property tests
637 it "Compose three - empty in the middle" $
638 ((tl $ (singleton 0 <> z <> singleton 1)) >>= return . srt)
639 `shouldReturn` [0, 1]
640 it "Compose left associated" $
641 ((tl $ (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3))
642 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
643 it "Compose right associated" $
644 ((tl $ (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3))))
645 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
646 it "Compose hierarchical (multiple levels)" $
647 ((tl $ (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))
648 <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))
649 ) >>= return . srt) `shouldReturn` [0..7]
650 where tl = S.toList . t
652composeAndComposeSimple
653 :: ( IsStream t1, Semigroup (t1 IO Int)
654 , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)
655#if __GLASGOW_HASKELL__ < 804
656 , Semigroup (t2 IO Int)
657#endif
658 )
659 => (t1 IO Int -> SerialT IO Int)
660 -> (t2 IO Int -> t2 IO Int)
661 -> [[Int]] -> Spec
662composeAndComposeSimple t1 t2 answer = do
663 let rfold = adapt . t2 . foldMapWith (<>) return
664 it "Compose right associated outer expr, right folded inner" $
665 ((S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9])))
666 `shouldReturn` (answer !! 0)
668 it "Compose left associated outer expr, right folded inner" $
669 ((S.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9]))
670 `shouldReturn` (answer !! 1)
672 let lfold xs = adapt $ t2 $ foldl (<>) mempty $ map return xs
673 it "Compose right associated outer expr, left folded inner" $
674 ((S.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9])))
675 `shouldReturn` (answer !! 2)
677 it "Compose left associated outer expr, left folded inner" $
678 ((S.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9]))
679 `shouldReturn` (answer !! 3)
681loops
682 :: (IsStream t, Semigroup (t IO Int), Monad (t IO))
683 => (t IO Int -> t IO Int)
684 -> ([Int] -> [Int])
685 -> ([Int] -> [Int])
686 -> Spec
687loops t tsrt hsrt = do
688 it "Tail recursive loop" $ ((S.toList . adapt) (loopTail 0) >>= return . tsrt)
689 `shouldReturn` [0..3]
691 it "Head recursive loop" $ ((S.toList . adapt) (loopHead 0) >>= return . hsrt)
692 `shouldReturn` [0..3]
694 where
695 loopHead x = do
696 -- this print line is important for the test (causes a bind)
697 S.yieldM $ putStrLn "LoopHead..."
698 t $ (if x < 3 then loopHead (x + 1) else nil) <> return x
700 loopTail x = do
701 -- this print line is important for the test (causes a bind)
702 S.yieldM $ putStrLn "LoopTail..."
703 t $ return x <> (if x < 3 then loopTail (x + 1) else nil)
705bindAndComposeSimple
706 :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))
707 => (t1 IO Int -> SerialT IO Int)
708 -> (t2 IO Int -> t2 IO Int)
709 -> Spec
710bindAndComposeSimple t1 t2 = do
711 -- XXX need a bind in the body of forEachWith instead of a simple return
712 it "Compose many (right fold) with bind" $
713 ((S.toList . t1) (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return)
714 >>= return . sort) `shouldReturn` [1..10]
716 it "Compose many (left fold) with bind" $
717 let forL xs k = foldl (<>) nil $ map k xs
718 in ((S.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return)
719 >>= return . sort) `shouldReturn` [1..10]
721bindAndComposeHierarchy
722 :: ( IsStream t1, Monad (t1 IO)
723 , IsStream t2, Monad (t2 IO))
724 => (t1 IO Int -> SerialT IO Int)
725 -> (t2 IO Int -> t2 IO Int)
726 -> ([t2 IO Int] -> t2 IO Int)
727 -> Spec
728bindAndComposeHierarchy t1 t2 g = do
729 it "Bind and compose nested" $
730 ((S.toList . t1) bindComposeNested >>= return . sort)
731 `shouldReturn` (sort (
732 [12, 18]
733 ++ replicate 3 13
734 ++ replicate 3 17
735 ++ replicate 6 14
736 ++ replicate 6 16
737 ++ replicate 7 15) :: [Int])
739 where
741 -- bindComposeNested :: WAsyncT IO Int
742 bindComposeNested =
743 let c1 = tripleCompose (return 1) (return 2) (return 3)
744 c2 = tripleCompose (return 4) (return 5) (return 6)
745 c3 = tripleCompose (return 7) (return 8) (return 9)
746 b = tripleBind c1 c2 c3
747-- it seems to be causing a huge space leak in hspec so disabling this for now
748-- c = tripleCompose b b b
749-- m = tripleBind c c c
750-- in m
751 in b
753 tripleCompose a b c = adapt . t2 $ g [a, b, c]
754 tripleBind mx my mz =
755 mx >>= \x -> my
756 >>= \y -> mz
757 >>= \z -> return (x + y + z)
759mixedOps :: Spec
760mixedOps = do
761 it "Compose many ops" $
762 (toListSerial composeMixed >>= return . sort)
763 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
764 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
765 ] :: [Int])
766 where
768 composeMixed :: SerialT IO Int
769 composeMixed = do
770 S.yieldM $ return ()
771 S.yieldM $ putStr ""
772 x <- return 1
773 y <- return 2
774 z <- do
775 x1 <- wAsyncly $ return 1 <> return 2
776 S.yieldM $ return ()
777 S.yieldM $ putStr ""
778 y1 <- asyncly $ return 1 <> return 2
779 z1 <- do
780 x11 <- return 1 <> return 2
781 y11 <- asyncly $ return 1 <> return 2
782 z11 <- wSerially $ return 1 <> return 2
783 S.yieldM $ return ()
784 S.yieldM $ putStr ""
785 return (x11 + y11 + z11)
786 return (x1 + y1 + z1)
787 return (x + y + z)
789mixedOpsAheadly :: Spec
790mixedOpsAheadly = do
791 it "Compose many ops" $
792 (toListSerial composeMixed >>= return . sort)
793 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
794 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
795 ] :: [Int])
796 where
798 composeMixed :: SerialT IO Int
799 composeMixed = do
800 S.yieldM $ return ()
801 S.yieldM $ putStr ""
802 x <- return 1
803 y <- return 2
804 z <- do
805 x1 <- wAsyncly $ return 1 <> return 2
806 S.yieldM $ return ()
807 S.yieldM $ putStr ""
808 y1 <- aheadly $ return 1 <> return 2
809 z1 <- do
810 x11 <- return 1 <> return 2
811 y11 <- aheadly $ return 1 <> return 2
812 z11 <- parallely $ return 1 <> return 2
813 S.yieldM $ return ()
814 S.yieldM $ putStr ""
815 return (x11 + y11 + z11)
816 return (x1 + y1 + z1)
817 return (x + y + z)