git.iko.soy/streamly
on 119e07a help sign in
streamly/test/Main.hs
621 lines 24 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE RankNTypes #-}
4module Main (main) where
6import Control.Concurrent (threadDelay)
7import Data.Foldable (forM_)
8import Data.List (sort)
9import Test.Hspec
11import Streamly
12import qualified Streamly.Prelude as A
14toListSerial :: StreamT IO a -> IO [a]
15toListSerial = A.toList . serially
17toListInterleaved :: InterleavedT IO a -> IO [a]
18toListInterleaved = A.toList . interleaving
20toListAsync :: AsyncT IO a -> IO [a]
21toListAsync = A.toList . asyncly
23toListParallel :: Ord a => ParallelT IO a -> IO [a]
24toListParallel = fmap sort . A.toList . parallely
26main :: IO ()
27main = hspec $ do
28 describe "Runners" $ do
29 it "simple serially" $
30 (runStreaming . serially) (return (0 :: Int)) `shouldReturn` ()
31 it "simple serially with IO" $
32 (runStreaming . serially) (liftIO $ putStrLn "hello") `shouldReturn` ()
33 it "Captures a return value using toList" $
34 toListSerial (return 0) `shouldReturn` ([0] :: [Int])
36 describe "Empty" $ do
37 it "Monoid - mempty" $
38 (toListSerial mempty) `shouldReturn` ([] :: [Int])
39 it "Alternative - empty" $
40 (toListSerial empty) `shouldReturn` ([] :: [Int])
41 it "MonadPlus - mzero" $
42 (toListSerial mzero) `shouldReturn` ([] :: [Int])
44 ---------------------------------------------------------------------------
45 -- Functor
46 ---------------------------------------------------------------------------
48 describe "Functor (fmap)" $ do
49 it "Simple fmap" $
50 (toListSerial $ fmap (+1) (return 1)) `shouldReturn` ([2] :: [Int])
51 it "fmap on composed (<>)" $
52 (toListSerial $ fmap (+1) (return 1 <> return 2))
53 `shouldReturn` ([2,3] :: [Int])
54 it "fmap on composed (<|>)" $
55 (toListSerial $ fmap (+1) (return 1 <|> return 2))
56 `shouldReturn` ([2,3] :: [Int])
58 ---------------------------------------------------------------------------
59 -- Applicative
60 ---------------------------------------------------------------------------
62 describe "Applicative" $ do
63 it "Simple apply" $
64 (toListSerial $ (,) <$> (return 1) <*> (return 2))
65 `shouldReturn` ([(1,2)] :: [(Int, Int)])
67 it "Apply - serial composed first argument" $
68 (toListSerial $ (,) <$> (return 1 <> return 2) <*> (return 3))
69 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
71 it "Apply - serial composed second argument" $
72 (toListSerial $ (,) <$> (return 1) <*> (return 2 <> return 3))
73 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
75 it "Apply - parallel composed first argument" $
76 (toListSerial $ (,) <$> (return 1 <|> return 2) <*> (return 3))
77 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
79 it "Apply - parallel composed second argument" $
80 (toListSerial $ (,) <$> (return 1) <*> (return 2 <|> return 3))
81 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
83 ---------------------------------------------------------------------------
84 -- Binds
85 ---------------------------------------------------------------------------
87 describe "Bind then" thenBind
88 describe "Pure bind serial" $ pureBind toListSerial
89 describe "Pure bind serial interleaved" $ pureBind toListInterleaved
90 describe "Pure bind parallel DFS" $ pureBind toListAsync
91 describe "Pure bind parallel BFS" $ pureBind toListParallel
93 describe "Bind (>>=) with empty" $ bindEmpty toListSerial
94 describe "Bind (>->) with empty" $ bindEmpty toListInterleaved
95 describe "Bind (>|>) with empty" $ bindEmpty toListAsync
96 describe "Bind (>>|) with empty" $ bindEmpty toListParallel
98 ---------------------------------------------------------------------------
99 -- Monoidal Compositions
100 ---------------------------------------------------------------------------
102 describe "Serial Composition (<>)" $ compose (<>) id
103 describe "Serial Composition (mappend)" $ compose mappend id
104 describe "Interleaved Composition (<>)" $ compose (<=>) sort
105 describe "Left biased parallel Composition (<|)" $ compose (<|) sort
106 describe "Fair parallel Composition (<|>)" $ compose (<|>) sort
107 describe "Fair parallel Composition (mplus)" $ compose mplus sort
109 ---------------------------------------------------------------------------
110 -- Monoidal Composition ordering checks
111 ---------------------------------------------------------------------------
113 describe "Serial interleaved ordering check (<=>)" $ interleaveCheck (<=>)
114 describe "Parallel interleaved ordering check (<|>)" $ interleaveCheck (<|>)
115 describe "Left biased parallel time order check" $ parallelCheck (<|)
116 describe "Fair parallel time order check" $ parallelCheck (<|>)
118 ---------------------------------------------------------------------------
119 -- TBD Monoidal composition combinations
120 ---------------------------------------------------------------------------
122 -- TBD need more such combinations to be tested.
123 describe "<> and <>" $ composeAndComposeSimple (<>) (<>) (cycle [[1 .. 9]])
125 describe "<> and <=>" $ composeAndComposeSimple
126 (<>)
127 (<=>)
128 ([ [1 .. 9]
129 , [1 .. 9]
130 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
131 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
132 ])
134 describe "<=> and <=>" $ composeAndComposeSimple
135 (<=>)
136 (<=>)
137 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
138 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
139 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
140 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
141 ])
143 describe "<=> and <>" $ composeAndComposeSimple
144 (<=>)
145 (<>)
146 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
147 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
148 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
149 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
150 ])
152 describe "Nested parallel and serial compositions" $ do
153 {-
154 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
155 -- because of parallelism of [8,0] and [8,0].
156 it "Nest <|>, <>, <|> (1)" $
157 let t = timed
158 in toListSerial (
159 ((t 8 <|> t 4) <> (t 2 <|> t 0))
160 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
161 `shouldReturn` ([4,4,8,8,0,0,2,2])
162 -}
163 it "Nest <|>, <>, <|> (2)" $
164 let t = timed
165 in toListSerial (
166 ((t 4 <|> t 8) <> (t 1 <|> t 2))
167 <|> ((t 4 <|> t 8) <> (t 1 <|> t 2)))
168 `shouldReturn` ([4,4,8,8,1,1,2,2])
169 -- FIXME: These two keep failing intermittently on Mac OS X
170 -- Need to examine and fix the tests.
171 {-
172 it "Nest <|>, <=>, <|> (1)" $
173 let t = timed
174 in toListSerial (
175 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
176 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
177 `shouldReturn` ([4,4,0,0,8,2,9,2])
178 it "Nest <|>, <=>, <|> (2)" $
179 let t = timed
180 in toListSerial (
181 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
182 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
183 `shouldReturn` ([4,4,1,1,8,2,9,2])
184 -}
185 it "Nest <|>, <|>, <|>" $
186 let t = timed
187 in toListSerial (
188 ((t 4 <|> t 8) <|> (t 0 <|> t 2))
189 <|> ((t 4 <|> t 8) <|> (t 0 <|> t 2)))
190 `shouldReturn` ([0,0,2,2,4,4,8,8])
192 ---------------------------------------------------------------------------
193 -- Monoidal composition recursion loops
194 ---------------------------------------------------------------------------
196 describe "Serial loops (<>)" $ loops (<>) id reverse
197 describe "Left biased parallel loops (<|)" $ loops (<|) sort sort
198 describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort
200 ---------------------------------------------------------------------------
201 -- Bind and monoidal composition combinations
202 ---------------------------------------------------------------------------
204 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
205 describe "Bind and compose" $ bindAndComposeSimple toListSerial g
207 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
208 describe "Bind and compose" $ bindAndComposeSimple toListInterleaved g
210 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
211 describe "Bind and compose" $ bindAndComposeSimple toListAsync g
213 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
214 describe "Bind and compose" $ bindAndComposeSimple toListParallel g
216 let fldr f = foldr f empty
217 fldl f = foldl f empty
218 in do
219 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
220 forM_ [fldr, fldl] $ \k ->
221 describe "Bind and compose" $
222 bindAndComposeHierarchy toListSerial (k g)
223 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
224 forM_ [fldr, fldl] $ \k ->
225 describe "Bind and compose" $
226 bindAndComposeHierarchy toListInterleaved (k g)
227 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
228 forM_ [fldr, fldl] $ \k ->
229 describe "Bind and compose" $
230 bindAndComposeHierarchy toListAsync (k g)
231 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
232 forM_ [fldr, fldl] $ \k ->
233 describe "Bind and compose" $
234 bindAndComposeHierarchy toListParallel (k g)
236 -- Nest two lists using different styles of product compositions
237 it "Nests two streams using monadic serial composition" nestTwoSerial
238 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
239 it "Nests two streams using monadic async composition" nestTwoAsync
240 it "Nests two streams using monadic parallel composition" nestTwoParallel
242 it "Nests two streams using applicative serial composition" nestTwoSerialApp
243 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
244 it "Nests two streams using applicative async composition" nestTwoAsyncApp
245 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
247 it "Nests two streams using Num serial composition" nestTwoSerialNum
248 it "Nests two streams using Num interleaved composition" nestTwoInterleavedNum
249 it "Nests two streams using Num async composition" nestTwoAsyncNum
250 -- This test fails intermittently, need to investigate
251 -- it "Nests two streams using Num parallel composition" nestTwoParallelNum
253 ---------------------------------------------------------------------------
254 -- TBD Bind and Bind combinations
255 ---------------------------------------------------------------------------
257 -- TBD combine all binds and all compose in one example
258 describe "Miscellaneous combined examples" mixedOps
260 describe "Transformation" $ transformOps (<>)
261 describe "Serial zipping" $
262 zipOps A.zipWith A.zipWithM zipping
263 describe "Async zipping" $
264 zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync
266nestTwoSerial :: Expectation
267nestTwoSerial =
268 let s1 = foldMapWith (<>) return [1..4]
269 s2 = foldMapWith (<>) return [5..8]
270 in toListSerial (do
271 x <- s1
272 y <- s2
273 return (x + y)
274 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
276nestTwoSerialApp :: Expectation
277nestTwoSerialApp =
278 let s1 = foldMapWith (<>) return [1..4]
279 s2 = foldMapWith (<>) return [5..8]
280 in toListSerial ((+) <$> s1 <*> s2)
281 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
283nestTwoSerialNum :: Expectation
284nestTwoSerialNum =
285 let s1 = foldMapWith (<>) return [1..4]
286 s2 = foldMapWith (<>) return [5..8]
287 in toListSerial (s1 + s2)
288 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
290nestTwoInterleaved :: Expectation
291nestTwoInterleaved =
292 let s1 = foldMapWith (<>) return [1..4]
293 s2 = foldMapWith (<>) return [5..8]
294 in toListInterleaved (do
295 x <- s1
296 y <- s2
297 return (x + y)
298 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
300nestTwoInterleavedApp :: Expectation
301nestTwoInterleavedApp =
302 let s1 = foldMapWith (<>) return [1..4]
303 s2 = foldMapWith (<>) return [5..8]
304 in toListInterleaved ((+) <$> s1 <*> s2)
305 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
307nestTwoInterleavedNum :: Expectation
308nestTwoInterleavedNum =
309 let s1 = foldMapWith (<>) return [1..4]
310 s2 = foldMapWith (<>) return [5..8]
311 in toListInterleaved (s1 + s2)
312 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
314nestTwoAsync :: Expectation
315nestTwoAsync =
316 let s1 = foldMapWith (<>) return [1..4]
317 s2 = foldMapWith (<>) return [5..8]
318 in toListAsync (do
319 x <- s1
320 y <- s2
321 return (x + y)
322 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
324nestTwoAsyncApp :: Expectation
325nestTwoAsyncApp =
326 let s1 = foldMapWith (<>) return [1..4]
327 s2 = foldMapWith (<>) return [5..8]
328 in toListAsync ((+) <$> s1 <*> s2)
329 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
331nestTwoAsyncNum :: Expectation
332nestTwoAsyncNum =
333 let s1 = foldMapWith (<>) return [1..4]
334 s2 = foldMapWith (<>) return [5..8]
335 in toListAsync (s1 + s2)
336 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
338nestTwoParallel :: Expectation
339nestTwoParallel =
340 let s1 = foldMapWith (<>) return [1..4]
341 s2 = foldMapWith (<>) return [5..8]
342 in toListParallel (do
343 x <- s1
344 y <- s2
345 return (x + y)
346 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
348nestTwoParallelApp :: Expectation
349nestTwoParallelApp =
350 let s1 = foldMapWith (<>) return [1..4]
351 s2 = foldMapWith (<>) return [5..8]
352 in toListParallel ((+) <$> s1 <*> s2)
353 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
355{-
356nestTwoParallelNum :: Expectation
357nestTwoParallelNum =
358 let s1 = foldMapWith (<>) return [1..4]
359 s2 = foldMapWith (<>) return [5..8]
360 in toListParallel (s1 + s2)
361 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
362-}
364zipOps :: (Streaming t, Applicative (t IO))
365 => (forall a b c. (a -> b -> c)
366 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
367 -> (forall a b c. (a -> b -> StreamT IO c)
368 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
369 -> (forall a. t IO a -> t IO a)
370 -> Spec
371zipOps z zM app = do
372 it "zipWith" $
373 let s1 = foldMapWith (<>) return [1..10]
374 s2 = foldMapWith (<>) return [1..]
375 in toListSerial (z (+) s1 s2)
376 `shouldReturn` ([2,4..20] :: [Int])
378 it "zipWithM" $
379 let s1 = foldMapWith (<>) return [1..10]
380 s2 = foldMapWith (<>) return [1..]
381 in toListSerial (zM (\a b -> return (a + b)) s1 s2)
382 `shouldReturn` ([2,4..20] :: [Int])
384 it "Applicative zip" $
385 let s1 = adapt $ serially $ foldMapWith (<>) return [1..10]
386 s2 = adapt $ serially $ foldMapWith (<>) return [1..]
387 in (A.toList . app) ((+) <$> s1 <*> s2)
388 `shouldReturn` ([2,4..20] :: [Int])
390timed :: Int -> StreamT IO Int
391timed x = liftIO (threadDelay (x * 100000)) >> return x
393thenBind :: Spec
394thenBind = do
395 it "Simple runStreaming and 'then' with IO" $
396 (runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
397 `shouldReturn` ()
398 it "Then and toList" $
399 toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
401type ToListType s = (forall a. Ord a => s IO a -> IO [a])
402pureBind :: Monad (s IO) => ToListType s -> Spec
403pureBind l = do
404 it "Bind and toList" $
405 l (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
406 `shouldReturn` ([3] :: [Int])
407 where f = (>>=)
409bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec
410bindEmpty l = it "Binds with empty" $
411 (l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2))
412 `shouldReturn` ([] :: [Int])
413 where f = (>>=)
415interleaveCheck
416 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
417 -> Spec
418interleaveCheck f =
419 it "Interleave four" $
420 toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101))
421 `shouldReturn` ([0, 100, 1, 101])
423parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
424parallelCheck f = do
425 it "Parallel ordering left associated" $
426 toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1)
427 `shouldReturn` ([1..4])
429 it "Parallel ordering right associated" $
430 toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
431 `shouldReturn` ([1..4])
433 where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
435compose
436 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
437 -> ([Int] -> [Int])
438 -> Spec
439compose f srt = do
440 it "Compose mempty, mempty" $
441 (tl (mempty `f` mempty)) `shouldReturn` []
442 it "Compose empty, empty" $
443 (tl (empty `f` empty)) `shouldReturn` []
444 it "Compose empty at the beginning" $
445 (tl $ (empty `f` return 1)) `shouldReturn` [1]
446 it "Compose empty at the end" $
447 (tl $ (return 1 `f` empty)) `shouldReturn` [1]
448 it "Compose two" $
449 (tl (return 0 `f` return 1) >>= return . srt)
450 `shouldReturn` [0, 1]
451 it "Compose three - empty in the middle" $
452 ((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt)
453 `shouldReturn` [0, 1]
454 it "Compose left associated" $
455 ((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
456 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
457 it "Compose right associated" $
458 ((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
459 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
460 it "Compose many" $
461 ((tl $ forEachWith f [1..100] return) >>= return . srt)
462 `shouldReturn` [1..100]
463 it "Compose hierarchical (multiple levels)" $
464 ((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
465 `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
466 ) >>= return . srt) `shouldReturn` [0..7]
467 where tl = toListSerial
469composeAndComposeSimple
470 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
471 -> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
472 -> [[Int]]
473 -> Spec
474composeAndComposeSimple f g answer = do
475 it "Compose right associated outer expr, right folded inner" $
476 let fold = foldMapWith g return
477 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
478 `shouldReturn` (answer !! 0)
480 it "Compose left associated outer expr, right folded inner" $
481 let fold = foldMapWith g return
482 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
483 `shouldReturn` (answer !! 1)
485 it "Compose right associated outer expr, left folded inner" $
486 let fold xs = foldl g empty $ map return xs
487 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
488 `shouldReturn` (answer !! 2)
490 it "Compose left associated outer expr, left folded inner" $
491 let fold xs = foldl g empty $ map return xs
492 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
493 `shouldReturn` (answer !! 3)
496loops
497 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
498 -> ([Int] -> [Int])
499 -> ([Int] -> [Int])
500 -> Spec
501loops f tsrt hsrt = do
502 it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt)
503 `shouldReturn` [0..3]
505 it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt)
506 `shouldReturn` [0..3]
508 where
509 loopHead x = do
510 -- this print line is important for the test (causes a bind)
511 liftIO $ putStrLn "LoopHead..."
512 (if x < 3 then loopHead (x + 1) else empty) `f` return x
514 loopTail x = do
515 -- this print line is important for the test (causes a bind)
516 liftIO $ putStrLn "LoopTail..."
517 return x `f` (if x < 3 then loopTail (x + 1) else empty)
519bindAndComposeSimple
520 :: (Streaming t, Alternative (t IO), Monad (t IO))
521 => (forall a. Ord a => t IO a -> IO [a])
522 -> (t IO Int -> t IO Int -> t IO Int)
523 -> Spec
524bindAndComposeSimple tl g = do
525 it "Compose many (right fold) with bind" $
526 (tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
527 >>= return . sort) `shouldReturn` [1..10]
529 it "Compose many (left fold) with bind" $
530 let forL xs k = foldl g empty $ map k xs
531 in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
532 >>= return . sort) `shouldReturn` [1..10]
533 where f = (>>=)
535bindAndComposeHierarchy
536 :: Monad (s IO) => (forall a. Ord a => s IO a -> IO [a])
537 -> ([s IO Int] -> s IO Int)
538 -> Spec
539bindAndComposeHierarchy tl g = do
540 it "Bind and compose nested" $
541 (tl bindComposeNested >>= return . sort)
542 `shouldReturn` (sort (
543 [12, 18]
544 ++ replicate 3 13
545 ++ replicate 3 17
546 ++ replicate 6 14
547 ++ replicate 6 16
548 ++ replicate 7 15) :: [Int])
550 where
552 -- bindComposeNested :: AsyncT IO Int
553 bindComposeNested =
554 let c1 = tripleCompose (return 1) (return 2) (return 3)
555 c2 = tripleCompose (return 4) (return 5) (return 6)
556 c3 = tripleCompose (return 7) (return 8) (return 9)
557 b = tripleBind c1 c2 c3
558-- it seems to be causing a huge space leak in hspec so disabling this for now
559-- c = tripleCompose b b b
560-- m = tripleBind c c c
561-- in m
562 in b
564 tripleCompose a b c = g [a, b, c]
565 tripleBind mx my mz =
566 mx `f` \x -> my
567 `f` \y -> mz
568 `f` \z -> return (x + y + z)
569 f = (>>=)
571mixedOps :: Spec
572mixedOps = do
573 it "Compose many ops" $
574 (toListSerial composeMixed >>= return . sort)
575 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
576 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
577 ] :: [Int])
578 where
580 composeMixed :: StreamT IO Int
581 composeMixed = do
582 liftIO $ return ()
583 liftIO $ putStr ""
584 x <- return 1
585 y <- return 2
586 z <- do
587 x1 <- return 1 <|> return 2
588 liftIO $ return ()
589 liftIO $ putStr ""
590 y1 <- return 1 <| return 2
591 z1 <- do
592 x11 <- return 1 <> return 2
593 y11 <- return 1 <| return 2
594 z11 <- return 1 <=> return 2
595 liftIO $ return ()
596 liftIO $ putStr ""
597 return (x11 + y11 + z11)
598 return (x1 + y1 + z1)
599 return (x + y + z)
601transformOps :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
602transformOps f = do
603 it "take all" $
604 (toListSerial $ A.take 10 $ foldMapWith f return [1..10])
605 `shouldReturn` [1..10]
606 it "take none" $
607 (toListSerial $ A.take 0 $ foldMapWith f return [1..10])
608 `shouldReturn` []
609 it "take 5" $
610 (toListSerial $ A.take 5 $ foldMapWith f return [1..10])
611 `shouldReturn` [1..5]
613 it "drop all" $
614 (toListSerial $ A.drop 10 $ foldMapWith f return [1..10])
615 `shouldReturn` []
616 it "drop none" $
617 (toListSerial $ A.drop 0 $ foldMapWith f return [1..10])
618 `shouldReturn` [1..10]
619 it "drop 5" $
620 (toListSerial $ A.drop 5 $ foldMapWith f return [1..10])
621 `shouldReturn` [6..10]