git.iko.soy/streamly
on ffa84b1 help sign in
streamly/test/Main.hs
613 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 Asyncly
12import qualified Asyncly.Prelude as A
14toListSerial :: StreamT IO a -> IO [a]
15toListSerial = toList . serially
17toListInterleaved :: InterleavedT IO a -> IO [a]
18toListInterleaved = toList . interleaving
20toListAsync :: AsyncT IO a -> IO [a]
21toListAsync = toList . asyncly
23toListParallel :: ParallelT IO a -> IO [a]
24toListParallel = 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 it "Nest <|>, <>, <|> (1)" $
154 let t = timed
155 in toListSerial (
156 ((t 8 <|> t 4) <> (t 2 <|> t 0))
157 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
158 `shouldReturn` ([4,4,8,8,0,0,2,2])
159 it "Nest <|>, <>, <|> (2)" $
160 let t = timed
161 in toListSerial (
162 ((t 4 <|> t 8) <> (t 1 <|> t 2))
163 <|> ((t 4 <|> t 8) <> (t 1 <|> t 2)))
164 `shouldReturn` ([4,4,8,8,1,1,2,2])
165 -- FIXME: These two keep failing intermittently on Mac OS X
166 -- Need to examine and fix the tests.
167 {-
168 it "Nest <|>, <=>, <|> (1)" $
169 let t = timed
170 in toListSerial (
171 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
172 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
173 `shouldReturn` ([4,4,0,0,8,2,9,2])
174 it "Nest <|>, <=>, <|> (2)" $
175 let t = timed
176 in toListSerial (
177 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
178 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
179 `shouldReturn` ([4,4,1,1,8,2,9,2])
180 -}
181 it "Nest <|>, <|>, <|>" $
182 let t = timed
183 in toListSerial (
184 ((t 4 <|> t 8) <|> (t 0 <|> t 2))
185 <|> ((t 4 <|> t 8) <|> (t 0 <|> t 2)))
186 `shouldReturn` ([0,0,2,2,4,4,8,8])
188 ---------------------------------------------------------------------------
189 -- Monoidal composition recursion loops
190 ---------------------------------------------------------------------------
192 describe "Serial loops (<>)" $ loops (<>) id reverse
193 describe "Left biased parallel loops (<|)" $ loops (<|) sort sort
194 describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort
196 ---------------------------------------------------------------------------
197 -- Bind and monoidal composition combinations
198 ---------------------------------------------------------------------------
200 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
201 describe "Bind and compose" $ bindAndComposeSimple toListSerial g
203 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
204 describe "Bind and compose" $ bindAndComposeSimple toListInterleaved g
206 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
207 describe "Bind and compose" $ bindAndComposeSimple toListAsync g
209 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
210 describe "Bind and compose" $ bindAndComposeSimple toListParallel g
212 let fldr f = foldr f empty
213 fldl f = foldl f empty
214 in do
215 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
216 forM_ [fldr, fldl] $ \k ->
217 describe "Bind and compose" $
218 bindAndComposeHierarchy toListSerial (k g)
219 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
220 forM_ [fldr, fldl] $ \k ->
221 describe "Bind and compose" $
222 bindAndComposeHierarchy toListInterleaved (k g)
223 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
224 forM_ [fldr, fldl] $ \k ->
225 describe "Bind and compose" $
226 bindAndComposeHierarchy toListAsync (k g)
227 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
228 forM_ [fldr, fldl] $ \k ->
229 describe "Bind and compose" $
230 bindAndComposeHierarchy toListParallel (k g)
232 -- Nest two lists using different styles of product compositions
233 it "Nests two streams using monadic serial composition" nestTwoSerial
234 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
235 it "Nests two streams using monadic async composition" nestTwoAsync
236 it "Nests two streams using monadic parallel composition" nestTwoParallel
238 it "Nests two streams using applicative serial composition" nestTwoSerialApp
239 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
240 it "Nests two streams using applicative async composition" nestTwoAsyncApp
241 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
243 it "Nests two streams using Num serial composition" nestTwoSerialNum
244 it "Nests two streams using Num interleaved composition" nestTwoInterleavedNum
245 it "Nests two streams using Num async composition" nestTwoAsyncNum
246 it "Nests two streams using Num parallel composition" nestTwoParallelNum
248 ---------------------------------------------------------------------------
249 -- TBD Bind and Bind combinations
250 ---------------------------------------------------------------------------
252 -- TBD combine all binds and all compose in one example
253 describe "Miscellaneous combined examples" mixedOps
255 describe "Transformation" $ transformOps (<>)
256 describe "Serial zipping" $
257 zipOps A.zipWith A.zipWithM zipping
258 describe "Async zipping" $
259 zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync
261nestTwoSerial :: Expectation
262nestTwoSerial =
263 let s1 = foldMapWith (<>) return [1..4]
264 s2 = foldMapWith (<>) return [5..8]
265 in toListSerial (do
266 x <- s1
267 y <- s2
268 return (x + y)
269 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
271nestTwoSerialApp :: Expectation
272nestTwoSerialApp =
273 let s1 = foldMapWith (<>) return [1..4]
274 s2 = foldMapWith (<>) return [5..8]
275 in toListSerial ((+) <$> s1 <*> s2)
276 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
278nestTwoSerialNum :: Expectation
279nestTwoSerialNum =
280 let s1 = foldMapWith (<>) return [1..4]
281 s2 = foldMapWith (<>) return [5..8]
282 in toListSerial (s1 + s2)
283 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
285nestTwoInterleaved :: Expectation
286nestTwoInterleaved =
287 let s1 = foldMapWith (<>) return [1..4]
288 s2 = foldMapWith (<>) return [5..8]
289 in toListInterleaved (do
290 x <- s1
291 y <- s2
292 return (x + y)
293 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
295nestTwoInterleavedApp :: Expectation
296nestTwoInterleavedApp =
297 let s1 = foldMapWith (<>) return [1..4]
298 s2 = foldMapWith (<>) return [5..8]
299 in toListInterleaved ((+) <$> s1 <*> s2)
300 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
302nestTwoInterleavedNum :: Expectation
303nestTwoInterleavedNum =
304 let s1 = foldMapWith (<>) return [1..4]
305 s2 = foldMapWith (<>) return [5..8]
306 in toListInterleaved (s1 + s2)
307 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
309nestTwoAsync :: Expectation
310nestTwoAsync =
311 let s1 = foldMapWith (<>) return [1..4]
312 s2 = foldMapWith (<>) return [5..8]
313 in toListAsync (do
314 x <- s1
315 y <- s2
316 return (x + y)
317 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
319nestTwoAsyncApp :: Expectation
320nestTwoAsyncApp =
321 let s1 = foldMapWith (<>) return [1..4]
322 s2 = foldMapWith (<>) return [5..8]
323 in toListAsync ((+) <$> s1 <*> s2)
324 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
326nestTwoAsyncNum :: Expectation
327nestTwoAsyncNum =
328 let s1 = foldMapWith (<>) return [1..4]
329 s2 = foldMapWith (<>) return [5..8]
330 in toListAsync (s1 + s2)
331 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
333nestTwoParallel :: Expectation
334nestTwoParallel =
335 let s1 = foldMapWith (<>) return [1..4]
336 s2 = foldMapWith (<>) return [5..8]
337 in toListParallel (do
338 x <- s1
339 y <- s2
340 return (x + y)
341 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
343nestTwoParallelApp :: Expectation
344nestTwoParallelApp =
345 let s1 = foldMapWith (<>) return [1..4]
346 s2 = foldMapWith (<>) return [5..8]
347 in toListParallel ((+) <$> s1 <*> s2)
348 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
350nestTwoParallelNum :: Expectation
351nestTwoParallelNum =
352 let s1 = foldMapWith (<>) return [1..4]
353 s2 = foldMapWith (<>) return [5..8]
354 in toListParallel (s1 + s2)
355 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
357zipOps :: (Streaming t, Applicative (t IO))
358 => (forall a b c. (a -> b -> c)
359 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
360 -> (forall a b c. (a -> b -> StreamT IO c)
361 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
362 -> (forall a. t IO a -> t IO a)
363 -> Spec
364zipOps z zM app = do
365 it "zipWith" $
366 let s1 = foldMapWith (<|>) return [1..10]
367 s2 = foldMapWith (<>) return [1..]
368 in toListSerial (z (+) s1 s2)
369 `shouldReturn` ([2,4..20] :: [Int])
371 it "zipWithM" $
372 let s1 = foldMapWith (<|>) return [1..10]
373 s2 = foldMapWith (<>) return [1..]
374 in toListSerial (zM (\a b -> return (a + b)) s1 s2)
375 `shouldReturn` ([2,4..20] :: [Int])
377 it "Applicative zip" $
378 let s1 = adapt $ serially $ foldMapWith (<|>) return [1..10]
379 s2 = adapt $ serially $ foldMapWith (<>) return [1..]
380 in (toList . app) ((+) <$> s1 <*> s2)
381 `shouldReturn` ([2,4..20] :: [Int])
383timed :: Int -> StreamT IO Int
384timed x = liftIO (threadDelay (x * 100000)) >> return x
386thenBind :: Spec
387thenBind = do
388 it "Simple runAsyncly and 'then' with IO" $
389 (runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
390 `shouldReturn` ()
391 it "Then and toList" $
392 toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
394type ToListType s = (forall a. s IO a -> IO [a])
395pureBind :: Monad (s IO) => ToListType s -> Spec
396pureBind l = do
397 it "Bind and toList" $
398 l (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
399 `shouldReturn` ([3] :: [Int])
400 where f = (>>=)
402bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec
403bindEmpty l = it "Binds with empty" $
404 (l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2))
405 `shouldReturn` ([] :: [Int])
406 where f = (>>=)
408interleaveCheck
409 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
410 -> Spec
411interleaveCheck f =
412 it "Interleave four" $
413 toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101))
414 `shouldReturn` ([0, 100, 1, 101])
416parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
417parallelCheck f = do
418 it "Parallel ordering left associated" $
419 toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1)
420 `shouldReturn` ([1..4])
422 it "Parallel ordering right associated" $
423 toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
424 `shouldReturn` ([1..4])
426 where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
428compose
429 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
430 -> ([Int] -> [Int])
431 -> Spec
432compose f srt = do
433 it "Compose mempty, mempty" $
434 (tl (mempty `f` mempty)) `shouldReturn` []
435 it "Compose empty, empty" $
436 (tl (empty `f` empty)) `shouldReturn` []
437 it "Compose empty at the beginning" $
438 (tl $ (empty `f` return 1)) `shouldReturn` [1]
439 it "Compose empty at the end" $
440 (tl $ (return 1 `f` empty)) `shouldReturn` [1]
441 it "Compose two" $
442 (tl (return 0 `f` return 1) >>= return . srt)
443 `shouldReturn` [0, 1]
444 it "Compose three - empty in the middle" $
445 ((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt)
446 `shouldReturn` [0, 1]
447 it "Compose left associated" $
448 ((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
449 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
450 it "Compose right associated" $
451 ((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
452 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
453 it "Compose many" $
454 ((tl $ forEachWith f [1..100] return) >>= return . srt)
455 `shouldReturn` [1..100]
456 it "Compose hierarchical (multiple levels)" $
457 ((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
458 `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
459 ) >>= return . srt) `shouldReturn` [0..7]
460 where tl = toListSerial
462composeAndComposeSimple
463 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
464 -> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
465 -> [[Int]]
466 -> Spec
467composeAndComposeSimple f g answer = do
468 it "Compose right associated outer expr, right folded inner" $
469 let fold = foldMapWith g return
470 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
471 `shouldReturn` (answer !! 0)
473 it "Compose left associated outer expr, right folded inner" $
474 let fold = foldMapWith g return
475 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
476 `shouldReturn` (answer !! 1)
478 it "Compose right associated outer expr, left folded inner" $
479 let fold xs = foldl g empty $ map return xs
480 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
481 `shouldReturn` (answer !! 2)
483 it "Compose left associated outer expr, left folded inner" $
484 let fold xs = foldl g empty $ map return xs
485 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
486 `shouldReturn` (answer !! 3)
489loops
490 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
491 -> ([Int] -> [Int])
492 -> ([Int] -> [Int])
493 -> Spec
494loops f tsrt hsrt = do
495 it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt)
496 `shouldReturn` [0..3]
498 it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt)
499 `shouldReturn` [0..3]
501 where
502 loopHead x = do
503 -- this print line is important for the test (causes a bind)
504 liftIO $ putStrLn "LoopHead..."
505 (if x < 3 then loopHead (x + 1) else empty) `f` return x
507 loopTail x = do
508 -- this print line is important for the test (causes a bind)
509 liftIO $ putStrLn "LoopTail..."
510 return x `f` (if x < 3 then loopTail (x + 1) else empty)
512bindAndComposeSimple
513 :: (Alternative (s IO), Monad (s IO), Monoid (s IO Int)) => (forall a. s IO a -> IO [a])
514 -> (s IO Int -> s IO Int -> s IO Int)
515 -> Spec
516bindAndComposeSimple tl g = do
517 it "Compose many (right fold) with bind" $
518 (tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
519 >>= return . sort) `shouldReturn` [1..10]
521 it "Compose many (left fold) with bind" $
522 let forL xs k = foldl g empty $ map k xs
523 in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
524 >>= return . sort) `shouldReturn` [1..10]
525 where f = (>>=)
527bindAndComposeHierarchy
528 :: Monad (s IO) => (forall a. s IO a -> IO [a])
529 -> ([s IO Int] -> s IO Int)
530 -> Spec
531bindAndComposeHierarchy tl g = do
532 it "Bind and compose nested" $
533 (tl bindComposeNested >>= return . sort)
534 `shouldReturn` (sort (
535 [12, 18]
536 ++ replicate 3 13
537 ++ replicate 3 17
538 ++ replicate 6 14
539 ++ replicate 6 16
540 ++ replicate 7 15) :: [Int])
542 where
544 -- bindComposeNested :: AsyncT IO Int
545 bindComposeNested =
546 let c1 = tripleCompose (return 1) (return 2) (return 3)
547 c2 = tripleCompose (return 4) (return 5) (return 6)
548 c3 = tripleCompose (return 7) (return 8) (return 9)
549 b = tripleBind c1 c2 c3
550-- it seems to be causing a huge space leak in hspec so disabling this for now
551-- c = tripleCompose b b b
552-- m = tripleBind c c c
553-- in m
554 in b
556 tripleCompose a b c = g [a, b, c]
557 tripleBind mx my mz =
558 mx `f` \x -> my
559 `f` \y -> mz
560 `f` \z -> return (x + y + z)
561 f = (>>=)
563mixedOps :: Spec
564mixedOps = do
565 it "Compose many ops" $
566 (toListSerial composeMixed >>= return . sort)
567 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
568 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
569 ] :: [Int])
570 where
572 composeMixed :: StreamT IO Int
573 composeMixed = do
574 liftIO $ return ()
575 liftIO $ putStr ""
576 x <- return 1
577 y <- return 2
578 z <- do
579 x1 <- return 1 <|> return 2
580 liftIO $ return ()
581 liftIO $ putStr ""
582 y1 <- return 1 <| return 2
583 z1 <- do
584 x11 <- return 1 <> return 2
585 y11 <- return 1 <| return 2
586 z11 <- return 1 <=> return 2
587 liftIO $ return ()
588 liftIO $ putStr ""
589 return (x11 + y11 + z11)
590 return (x1 + y1 + z1)
591 return (x + y + z)
593transformOps :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
594transformOps f = do
595 it "take all" $
596 (toListSerial $ A.take 10 $ foldMapWith f return [1..10])
597 `shouldReturn` [1..10]
598 it "take none" $
599 (toListSerial $ A.take 0 $ foldMapWith f return [1..10])
600 `shouldReturn` []
601 it "take 5" $
602 (toListSerial $ A.take 5 $ foldMapWith f return [1..10])
603 `shouldReturn` [1..5]
605 it "drop all" $
606 (toListSerial $ A.drop 10 $ foldMapWith f return [1..10])
607 `shouldReturn` []
608 it "drop none" $
609 (toListSerial $ A.drop 0 $ foldMapWith f return [1..10])
610 `shouldReturn` [1..10]
611 it "drop 5" $
612 (toListSerial $ A.drop 5 $ foldMapWith f return [1..10])
613 `shouldReturn` [6..10]