git.iko.soy/streamly
on 20b592a help sign in
streamly/test/Main.hs
648 lines 27 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_)
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 :: StreamT IO a -> IO [a]
24toListSerial = A.toList . streamly
26toListInterleaved :: CostreamT IO a -> IO [a]
27toListInterleaved = A.toList . costreamly
29toListAsync :: CoparallelT IO a -> IO [a]
30toListAsync = A.toList . coparallely
32toListParallel :: ParallelT IO a -> IO [a]
33toListParallel = A.toList . parallely
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 streamly" $
41 (runStream . streamly) (return (0 :: Int)) `shouldReturn` ()
42 it "simple streamly with IO" $
43 (runStream . streamly) (liftIO $ 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 costreamly (<>)
100 describe "Serial interleaved mappend ordering check" $ interleaveCheck costreamly mappend
102 describe "Parallel interleaved (<>) ordering check" $ interleaveCheck parallely (<>)
103 describe "Parallel interleaved mappend ordering check" $ interleaveCheck parallely mappend
105 describe "Coparallel (<>) time order check" $ parallelCheck coparallely (<>)
106 describe "Coparallel mappend time order check" $ parallelCheck coparallely mappend
107 describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)
108 describe "Parallel mappend time order check" $ parallelCheck parallely mappend
110 ---------------------------------------------------------------------------
111 -- Monoidal Compositions, multiset equality checks
112 ---------------------------------------------------------------------------
114 describe "Serial Composition" $ compose streamly mempty id
115 describe "Interleaved Composition" $ compose costreamly mempty sort
116 describe "Left biased parallel Composition" $ compose coparallely mempty sort
117 describe "Fair parallel Composition" $ compose parallely mempty sort
118 describe "Semigroup Composition for ZipSerial" $ compose zipStreamly mempty id
119 describe "Semigroup Composition for ZipAsync" $ compose zipParallely mempty id
120 -- XXX need to check alternative compositions as well
122 ---------------------------------------------------------------------------
123 -- TBD Monoidal composition combinations
124 ---------------------------------------------------------------------------
126 -- TBD need more such combinations to be tested.
127 describe "<> and <>" $ composeAndComposeSimple streamly streamly (cycle [[1 .. 9]])
129 describe "<> and <=>" $ composeAndComposeSimple
130 streamly
131 costreamly
132 ([ [1 .. 9]
133 , [1 .. 9]
134 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
135 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
136 ])
138 describe "<=> and <=>" $ composeAndComposeSimple
139 costreamly
140 costreamly
141 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
142 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
143 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
144 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
145 ])
147 describe "<=> and <>" $ composeAndComposeSimple
148 costreamly
149 streamly
150 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
151 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
152 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
153 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
154 ])
156 describe "Nested parallel and serial compositions" $ do
157 let t = timed
158 p = parallely
159 s = streamly
160 {-
161 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
162 -- because of parallelism of [8,0] and [8,0].
163 it "Nest <|>, <>, <|> (1)" $
164 let t = timed
165 in toListSerial (
166 ((t 8 <|> t 4) <> (t 2 <|> t 0))
167 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
168 `shouldReturn` ([4,4,8,8,0,0,2,2])
169 -}
170 it "Nest <|>, <>, <|> (2)" $
171 (A.toList . parallely) (
172 s (p (t 4 <> t 8) <> p (t 1 <> t 2))
173 <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))
174 `shouldReturn` ([4,4,8,8,1,1,2,2])
175 -- FIXME: These two keep failing intermittently on Mac OS X
176 -- Need to examine and fix the tests.
177 {-
178 it "Nest <|>, <=>, <|> (1)" $
179 let t = timed
180 in toListSerial (
181 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
182 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
183 `shouldReturn` ([4,4,0,0,8,2,9,2])
184 it "Nest <|>, <=>, <|> (2)" $
185 let t = timed
186 in toListSerial (
187 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
188 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
189 `shouldReturn` ([4,4,1,1,8,2,9,2])
190 -}
191 it "Nest <|>, <|>, <|>" $
192 (A.toList . parallely) (
193 ((t 4 <> t 8) <> (t 0 <> t 2))
194 <> ((t 4 <> t 8) <> (t 0 <> t 2)))
195 `shouldReturn` ([0,0,2,2,4,4,8,8])
197 ---------------------------------------------------------------------------
198 -- Monoidal composition recursion loops
199 ---------------------------------------------------------------------------
201 describe "Serial loops (<>)" $ loops streamly id reverse
202 describe "Left biased parallel loops (<|)" $ loops coparallely sort sort
203 describe "Fair parallel loops (<|>)" $ loops parallely sort sort
205 ---------------------------------------------------------------------------
206 -- Bind and monoidal composition combinations
207 ---------------------------------------------------------------------------
209 describe "Bind and compose1" $ bindAndComposeSimple streamly streamly
210 describe "Bind and compose2" $ bindAndComposeSimple streamly costreamly
211 describe "Bind and compose3" $ bindAndComposeSimple streamly coparallely
212 describe "Bind and compose4" $ bindAndComposeSimple streamly parallely
214 describe "Bind and compose1" $ bindAndComposeSimple costreamly streamly
215 describe "Bind and compose2" $ bindAndComposeSimple costreamly costreamly
216 describe "Bind and compose3" $ bindAndComposeSimple costreamly coparallely
217 describe "Bind and compose4" $ bindAndComposeSimple costreamly parallely
219 describe "Bind and compose1" $ bindAndComposeSimple coparallely streamly
220 describe "Bind and compose2" $ bindAndComposeSimple coparallely costreamly
221 describe "Bind and compose3" $ bindAndComposeSimple coparallely coparallely
222 describe "Bind and compose4" $ bindAndComposeSimple coparallely parallely
224 describe "Bind and compose1" $ bindAndComposeSimple parallely streamly
225 describe "Bind and compose2" $ bindAndComposeSimple parallely costreamly
226 describe "Bind and compose3" $ bindAndComposeSimple parallely coparallely
227 describe "Bind and compose4" $ bindAndComposeSimple parallely parallely
229 let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int
230 fldr = foldr (<>) nil
231 fldl = foldl (<>) nil
233 forM_ [fldr, fldl] $ \k ->
234 describe "Bind and compose" $ bindAndComposeHierarchy streamly streamly k
235 forM_ [fldr, fldl] $ \k ->
236 describe "Bind and compose" $ bindAndComposeHierarchy streamly costreamly k
237 forM_ [fldr, fldl] $ \k ->
238 describe "Bind and compose" $ bindAndComposeHierarchy streamly coparallely k
239 forM_ [fldr, fldl] $ \k ->
240 describe "Bind and compose" $ bindAndComposeHierarchy streamly parallely k
242 forM_ [fldr, fldl] $ \k ->
243 describe "Bind and compose" $ bindAndComposeHierarchy costreamly streamly k
244 forM_ [fldr, fldl] $ \k ->
245 describe "Bind and compose" $ bindAndComposeHierarchy costreamly costreamly k
246 forM_ [fldr, fldl] $ \k ->
247 describe "Bind and compose" $ bindAndComposeHierarchy costreamly coparallely k
248 forM_ [fldr, fldl] $ \k ->
249 describe "Bind and compose" $ bindAndComposeHierarchy costreamly parallely k
251 forM_ [fldr, fldl] $ \k ->
252 describe "Bind and compose" $ bindAndComposeHierarchy coparallely streamly k
253 forM_ [fldr, fldl] $ \k ->
254 describe "Bind and compose" $ bindAndComposeHierarchy coparallely costreamly k
255 forM_ [fldr, fldl] $ \k ->
256 describe "Bind and compose" $ bindAndComposeHierarchy coparallely coparallely k
257 forM_ [fldr, fldl] $ \k ->
258 describe "Bind and compose" $ bindAndComposeHierarchy coparallely parallely k
260 forM_ [fldr, fldl] $ \k ->
261 describe "Bind and compose" $ bindAndComposeHierarchy parallely streamly k
262 forM_ [fldr, fldl] $ \k ->
263 describe "Bind and compose" $ bindAndComposeHierarchy parallely costreamly k
264 forM_ [fldr, fldl] $ \k ->
265 describe "Bind and compose" $ bindAndComposeHierarchy parallely coparallely k
266 forM_ [fldr, fldl] $ \k ->
267 describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k
269 -- Nest two lists using different styles of product compositions
270 it "Nests two streams using monadic serial composition" nestTwoSerial
271 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
272 it "Nests two streams using monadic async composition" nestTwoAsync
273 it "Nests two streams using monadic parallel composition" nestTwoParallel
275 it "Nests two streams using applicative serial composition" nestTwoSerialApp
276 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
277 it "Nests two streams using applicative async composition" nestTwoAsyncApp
278 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
280 ---------------------------------------------------------------------------
281 -- TBD Bind and Bind combinations
282 ---------------------------------------------------------------------------
284 -- TBD combine all binds and all compose in one example
285 describe "Miscellaneous combined examples" mixedOps
286 describe "Simple MonadError and MonadThrow" simpleMonadError
288 {-
289 describe "Composed MonadError streamly" $ composeWithMonadError streamly
290 describe "Composed MonadError costreamly" $ composeWithMonadError costreamly
291 describe "Composed MonadError coparallely" $ composeWithMonadError coparallely
292 describe "Composed MonadError parallely" $ composeWithMonadError parallely
293 -}
295 describe "Composed MonadThrow streamly" $ composeWithMonadThrow streamly
296 describe "Composed MonadThrow costreamly" $ composeWithMonadThrow costreamly
297 describe "Composed MonadThrow coparallely" $ composeWithMonadThrow coparallely
298 describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely
300-- XXX need to test that we have promptly cleaned up everything after the error
301-- XXX We can also check the output that we are expected to get before the
302-- error occurs.
304data ExampleException = ExampleException String deriving (Eq, Show)
306instance Exception ExampleException
308simpleMonadError :: Spec
309simpleMonadError = do
310{-
311 it "simple runExceptT" $ do
312 (runExceptT $ runStream $ return ())
313 `shouldReturn` (Right () :: Either String ())
314 it "simple runExceptT with error" $ do
315 (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"
316 -}
317 it "simple try" $ do
318 (try $ runStream $ return ())
319 `shouldReturn` (Right () :: Either ExampleException ())
320 it "simple try with throw error" $ do
321 (try $ runStream $ throwM $ ExampleException "E")
322 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
324composeWithMonadThrow
325 :: ( IsStream t
326 , Semigroup (t IO Int)
327 , MonadThrow (t IO)
328 )
329 => (t IO Int -> StreamT IO Int) -> Spec
330composeWithMonadThrow t = do
331 it "Compose throwM, nil" $
332 (try $ tl (throwM (ExampleException "E") <> A.nil))
333 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
334 it "Compose nil, throwM" $
335 (try $ tl (A.nil <> throwM (ExampleException "E")))
336 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
337 oneLevelNestedSum "streamly" streamly
338 oneLevelNestedSum "costreamly" costreamly
339 oneLevelNestedSum "coparallely" coparallely
340 oneLevelNestedSum "parallely" parallely
341 -- XXX add two level nesting
343 oneLevelNestedProduct "streamly" streamly
344 oneLevelNestedProduct "costreamly" costreamly
345 oneLevelNestedProduct "coparallely" coparallely
346 oneLevelNestedProduct "parallely" parallely
348 where
349 tl = A.toList . t
350 oneLevelNestedSum desc t1 =
351 it ("One level nested sum " ++ desc) $ do
352 let nested = (A.fromFoldable [1..10] <> throwM (ExampleException "E")
353 <> A.fromFoldable [1..10])
354 (try $ tl (A.nil <> t1 nested <> A.fromFoldable [1..10]))
355 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
357 oneLevelNestedProduct desc t1 =
358 it ("One level nested product" ++ desc) $ do
359 let s1 = t $ foldMapWith (<>) return [1..4]
360 s2 = t1 $ foldMapWith (<>) return [5..8]
361 try $ tl (do
362 x <- adapt s1
363 y <- s2
364 if (x + y > 10)
365 then throwM (ExampleException "E")
366 else return (x + y)
367 )
368 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
370_composeWithMonadError
371 :: ( IsStream t
372 , Semigroup (t (ExceptT String IO) Int)
373 , MonadError String (t (ExceptT String IO))
374 )
375 => (t (ExceptT String IO) Int -> StreamT (ExceptT String IO) Int) -> Spec
376_composeWithMonadError t = do
377 let tl = A.toList . t
378 it "Compose throwError, nil" $
379 (runExceptT $ tl (throwError "E" <> A.nil)) `shouldReturn` Left "E"
380 it "Compose nil, error" $
381 (runExceptT $ tl (A.nil <> throwError "E")) `shouldReturn` Left "E"
383nestTwoSerial :: Expectation
384nestTwoSerial =
385 let s1 = foldMapWith (<>) return [1..4]
386 s2 = foldMapWith (<>) return [5..8]
387 in toListSerial (do
388 x <- s1
389 y <- s2
390 return (x + y)
391 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
393nestTwoSerialApp :: Expectation
394nestTwoSerialApp =
395 let s1 = foldMapWith (<>) return [1..4]
396 s2 = foldMapWith (<>) return [5..8]
397 in toListSerial ((+) <$> s1 <*> s2)
398 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
400nestTwoInterleaved :: Expectation
401nestTwoInterleaved =
402 let s1 = foldMapWith (<>) return [1..4]
403 s2 = foldMapWith (<>) return [5..8]
404 in toListInterleaved (do
405 x <- s1
406 y <- s2
407 return (x + y)
408 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
410nestTwoInterleavedApp :: Expectation
411nestTwoInterleavedApp =
412 let s1 = foldMapWith (<>) return [1..4]
413 s2 = foldMapWith (<>) return [5..8]
414 in toListInterleaved ((+) <$> s1 <*> s2)
415 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
417nestTwoAsync :: Expectation
418nestTwoAsync =
419 let s1 = foldMapWith (<>) return [1..4]
420 s2 = foldMapWith (<>) return [5..8]
421 in (toListAsync (do
422 x <- s1
423 y <- s2
424 return (x + y)
425 ) >>= return . sort)
426 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
428nestTwoAsyncApp :: Expectation
429nestTwoAsyncApp =
430 let s1 = foldMapWith (<>) return [1..4]
431 s2 = foldMapWith (<>) return [5..8]
432 in (toListAsync ((+) <$> s1 <*> s2) >>= return . sort)
433 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
435nestTwoParallel :: Expectation
436nestTwoParallel =
437 let s1 = foldMapWith (<>) return [1..4]
438 s2 = foldMapWith (<>) return [5..8]
439 in (toListParallel (do
440 x <- s1
441 y <- s2
442 return (x + y)
443 ) >>= return . sort)
444 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
446nestTwoParallelApp :: Expectation
447nestTwoParallelApp =
448 let s1 = foldMapWith (<>) return [1..4]
449 s2 = foldMapWith (<>) return [5..8]
450 in (toListParallel ((+) <$> s1 <*> s2) >>= return . sort)
451 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
453timed :: MonadIO (t IO) => Int -> t IO Int
454timed x = liftIO (threadDelay (x * 100000)) >> return x
456interleaveCheck :: IsStream t
457 => (t IO Int -> StreamT IO Int)
458 -> (t IO Int -> t IO Int -> t IO Int)
459 -> Spec
460interleaveCheck t f =
461 it "Interleave four" $
462 (A.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))
463 `shouldReturn` ([0, 100, 1, 101])
465parallelCheck :: MonadIO (t IO)
466 => (t IO Int -> StreamT IO Int)
467 -> (t IO Int -> t IO Int -> t IO Int)
468 -> Spec
469parallelCheck t f = do
470 it "Parallel ordering left associated" $
471 (A.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)
472 `shouldReturn` ([1..4])
474 it "Parallel ordering right associated" $
475 (A.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
476 `shouldReturn` ([1..4])
478 where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
480compose :: (IsStream t, Semigroup (t IO Int))
481 => (t IO Int -> StreamT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec
482compose t z srt = do
483 -- XXX these should get covered by the property tests
484 it "Compose mempty, mempty" $
485 (tl (z <> z)) `shouldReturn` ([] :: [Int])
486 it "Compose empty at the beginning" $
487 (tl $ (z <> singleton 1)) `shouldReturn` [1]
488 it "Compose empty at the end" $
489 (tl $ (singleton 1 <> z)) `shouldReturn` [1]
490 it "Compose two" $
491 (tl (singleton 0 <> singleton 1) >>= return . srt)
492 `shouldReturn` [0, 1]
493 it "Compose many" $
494 ((tl $ forEachWith (<>) [1..100] singleton) >>= return . srt)
495 `shouldReturn` [1..100]
497 -- These are not covered by the property tests
498 it "Compose three - empty in the middle" $
499 ((tl $ (singleton 0 <> z <> singleton 1)) >>= return . srt)
500 `shouldReturn` [0, 1]
501 it "Compose left associated" $
502 ((tl $ (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3))
503 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
504 it "Compose right associated" $
505 ((tl $ (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3))))
506 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
507 it "Compose hierarchical (multiple levels)" $
508 ((tl $ (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))
509 <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))
510 ) >>= return . srt) `shouldReturn` [0..7]
511 where tl = A.toList . t
513composeAndComposeSimple
514 :: ( IsStream t1, Semigroup (t1 IO Int)
515 , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)
516#if __GLASGOW_HASKELL__ < 804
517 , Semigroup (t2 IO Int)
518#endif
519 )
520 => (t1 IO Int -> StreamT IO Int)
521 -> (t2 IO Int -> t2 IO Int)
522 -> [[Int]] -> Spec
523composeAndComposeSimple t1 t2 answer = do
524 let rfold = adapt . t2 . foldMapWith (<>) return
525 it "Compose right associated outer expr, right folded inner" $
526 ((A.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9])))
527 `shouldReturn` (answer !! 0)
529 it "Compose left associated outer expr, right folded inner" $
530 ((A.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9]))
531 `shouldReturn` (answer !! 1)
533 let lfold xs = adapt $ t2 $ foldl (<>) mempty $ map return xs
534 it "Compose right associated outer expr, left folded inner" $
535 ((A.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9])))
536 `shouldReturn` (answer !! 2)
538 it "Compose left associated outer expr, left folded inner" $
539 ((A.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9]))
540 `shouldReturn` (answer !! 3)
542loops
543 :: (IsStream t, Semigroup (t IO Int), MonadIO (t IO))
544 => (t IO Int -> t IO Int)
545 -> ([Int] -> [Int])
546 -> ([Int] -> [Int])
547 -> Spec
548loops t tsrt hsrt = do
549 it "Tail recursive loop" $ ((A.toList . adapt) (loopTail 0) >>= return . tsrt)
550 `shouldReturn` [0..3]
552 it "Head recursive loop" $ ((A.toList . adapt) (loopHead 0) >>= return . hsrt)
553 `shouldReturn` [0..3]
555 where
556 loopHead x = do
557 -- this print line is important for the test (causes a bind)
558 liftIO $ putStrLn "LoopHead..."
559 t $ (if x < 3 then loopHead (x + 1) else nil) <> return x
561 loopTail x = do
562 -- this print line is important for the test (causes a bind)
563 liftIO $ putStrLn "LoopTail..."
564 t $ return x <> (if x < 3 then loopTail (x + 1) else nil)
566bindAndComposeSimple
567 :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))
568 => (t1 IO Int -> StreamT IO Int)
569 -> (t2 IO Int -> t2 IO Int)
570 -> Spec
571bindAndComposeSimple t1 t2 = do
572 -- XXX need a bind in the body of forEachWith instead of a simple return
573 it "Compose many (right fold) with bind" $
574 ((A.toList . t1) (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return)
575 >>= return . sort) `shouldReturn` [1..10]
577 it "Compose many (left fold) with bind" $
578 let forL xs k = foldl (<>) nil $ map k xs
579 in ((A.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return)
580 >>= return . sort) `shouldReturn` [1..10]
582bindAndComposeHierarchy
583 :: ( IsStream t1, Monad (t1 IO)
584 , IsStream t2, Monad (t2 IO))
585 => (t1 IO Int -> StreamT IO Int)
586 -> (t2 IO Int -> t2 IO Int)
587 -> ([t2 IO Int] -> t2 IO Int)
588 -> Spec
589bindAndComposeHierarchy t1 t2 g = do
590 it "Bind and compose nested" $
591 ((A.toList . t1) bindComposeNested >>= return . sort)
592 `shouldReturn` (sort (
593 [12, 18]
594 ++ replicate 3 13
595 ++ replicate 3 17
596 ++ replicate 6 14
597 ++ replicate 6 16
598 ++ replicate 7 15) :: [Int])
600 where
602 -- bindComposeNested :: AParallelT IO Int
603 bindComposeNested =
604 let c1 = tripleCompose (return 1) (return 2) (return 3)
605 c2 = tripleCompose (return 4) (return 5) (return 6)
606 c3 = tripleCompose (return 7) (return 8) (return 9)
607 b = tripleBind c1 c2 c3
608-- it seems to be causing a huge space leak in hspec so disabling this for now
609-- c = tripleCompose b b b
610-- m = tripleBind c c c
611-- in m
612 in b
614 tripleCompose a b c = adapt . t2 $ g [a, b, c]
615 tripleBind mx my mz =
616 mx >>= \x -> my
617 >>= \y -> mz
618 >>= \z -> return (x + y + z)
620mixedOps :: Spec
621mixedOps = do
622 it "Compose many ops" $
623 (toListSerial composeMixed >>= return . sort)
624 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
625 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
626 ] :: [Int])
627 where
629 composeMixed :: StreamT IO Int
630 composeMixed = do
631 liftIO $ return ()
632 liftIO $ putStr ""
633 x <- return 1
634 y <- return 2
635 z <- do
636 x1 <- parallely $ return 1 <> return 2
637 liftIO $ return ()
638 liftIO $ putStr ""
639 y1 <- coparallely $ return 1 <> return 2
640 z1 <- do
641 x11 <- return 1 <> return 2
642 y11 <- coparallely $ return 1 <> return 2
643 z11 <- costreamly $ return 1 <> return 2
644 liftIO $ return ()
645 liftIO $ putStr ""
646 return (x11 + y11 + z11)
647 return (x1 + y1 + z1)
648 return (x + y + z)