git.iko.soy/streamly
on 7daee5c help sign in
streamly/test/Main.hs
636 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 ((<>) :: StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
262 describe "Serial zipping" $
263 zipOps A.zipWith A.zipWithM zipping
264 describe "Async zipping" $
265 zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync
267nestTwoSerial :: Expectation
268nestTwoSerial =
269 let s1 = foldMapWith (<>) return [1..4]
270 s2 = foldMapWith (<>) return [5..8]
271 in toListSerial (do
272 x <- s1
273 y <- s2
274 return (x + y)
275 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
277nestTwoSerialApp :: Expectation
278nestTwoSerialApp =
279 let s1 = foldMapWith (<>) return [1..4]
280 s2 = foldMapWith (<>) return [5..8]
281 in toListSerial ((+) <$> s1 <*> s2)
282 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
284nestTwoSerialNum :: Expectation
285nestTwoSerialNum =
286 let s1 = foldMapWith (<>) return [1..4]
287 s2 = foldMapWith (<>) return [5..8]
288 in toListSerial (s1 + s2)
289 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
291nestTwoInterleaved :: Expectation
292nestTwoInterleaved =
293 let s1 = foldMapWith (<>) return [1..4]
294 s2 = foldMapWith (<>) return [5..8]
295 in toListInterleaved (do
296 x <- s1
297 y <- s2
298 return (x + y)
299 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
301nestTwoInterleavedApp :: Expectation
302nestTwoInterleavedApp =
303 let s1 = foldMapWith (<>) return [1..4]
304 s2 = foldMapWith (<>) return [5..8]
305 in toListInterleaved ((+) <$> s1 <*> s2)
306 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
308nestTwoInterleavedNum :: Expectation
309nestTwoInterleavedNum =
310 let s1 = foldMapWith (<>) return [1..4]
311 s2 = foldMapWith (<>) return [5..8]
312 in toListInterleaved (s1 + s2)
313 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
315nestTwoAsync :: Expectation
316nestTwoAsync =
317 let s1 = foldMapWith (<>) return [1..4]
318 s2 = foldMapWith (<>) return [5..8]
319 in toListAsync (do
320 x <- s1
321 y <- s2
322 return (x + y)
323 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
325nestTwoAsyncApp :: Expectation
326nestTwoAsyncApp =
327 let s1 = foldMapWith (<>) return [1..4]
328 s2 = foldMapWith (<>) return [5..8]
329 in toListAsync ((+) <$> s1 <*> s2)
330 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
332nestTwoAsyncNum :: Expectation
333nestTwoAsyncNum =
334 let s1 = foldMapWith (<>) return [1..4]
335 s2 = foldMapWith (<>) return [5..8]
336 in toListAsync (s1 + s2)
337 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
339nestTwoParallel :: Expectation
340nestTwoParallel =
341 let s1 = foldMapWith (<>) return [1..4]
342 s2 = foldMapWith (<>) return [5..8]
343 in toListParallel (do
344 x <- s1
345 y <- s2
346 return (x + y)
347 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
349nestTwoParallelApp :: Expectation
350nestTwoParallelApp =
351 let s1 = foldMapWith (<>) return [1..4]
352 s2 = foldMapWith (<>) return [5..8]
353 in toListParallel ((+) <$> s1 <*> s2)
354 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
356{-
357nestTwoParallelNum :: Expectation
358nestTwoParallelNum =
359 let s1 = foldMapWith (<>) return [1..4]
360 s2 = foldMapWith (<>) return [5..8]
361 in toListParallel (s1 + s2)
362 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
363-}
365zipOps :: (Streaming t, Applicative (t IO))
366 => (forall a b c. (a -> b -> c)
367 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
368 -> (forall a b c. (a -> b -> StreamT IO c)
369 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
370 -> (forall a. t IO a -> t IO a)
371 -> Spec
372zipOps z zM app = do
373 it "zipWith" $
374 let s1 = foldMapWith (<>) return [1..10]
375 s2 = foldMapWith (<>) return [1..]
376 in toListSerial (z (+) s1 s2)
377 `shouldReturn` ([2,4..20] :: [Int])
379 it "zipWithM" $
380 let s1 = foldMapWith (<>) return [1..10]
381 s2 = foldMapWith (<>) return [1..]
382 in toListSerial (zM (\a b -> return (a + b)) s1 s2)
383 `shouldReturn` ([2,4..20] :: [Int])
385 it "Applicative zip" $
386 let s1 = adapt $ serially $ foldMapWith (<>) return [1..10]
387 s2 = adapt $ serially $ foldMapWith (<>) return [1..]
388 in (A.toList . app) ((+) <$> s1 <*> s2)
389 `shouldReturn` ([2,4..20] :: [Int])
391timed :: Int -> StreamT IO Int
392timed x = liftIO (threadDelay (x * 100000)) >> return x
394thenBind :: Spec
395thenBind = do
396 it "Simple runStreaming and 'then' with IO" $
397 (runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
398 `shouldReturn` ()
399 it "Then and toList" $
400 toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
402type ToListType s = (forall a. Ord a => s IO a -> IO [a])
403pureBind :: Monad (s IO) => ToListType s -> Spec
404pureBind l = do
405 it "Bind and toList" $
406 l (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
407 `shouldReturn` ([3] :: [Int])
408 where f = (>>=)
410bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec
411bindEmpty l = it "Binds with empty" $
412 (l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2))
413 `shouldReturn` ([] :: [Int])
414 where f = (>>=)
416interleaveCheck
417 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
418 -> Spec
419interleaveCheck f =
420 it "Interleave four" $
421 toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101))
422 `shouldReturn` ([0, 100, 1, 101])
424parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
425parallelCheck f = do
426 it "Parallel ordering left associated" $
427 toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1)
428 `shouldReturn` ([1..4])
430 it "Parallel ordering right associated" $
431 toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
432 `shouldReturn` ([1..4])
434 where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
436compose
437 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
438 -> ([Int] -> [Int])
439 -> Spec
440compose f srt = do
441 it "Compose mempty, mempty" $
442 (tl (mempty `f` mempty)) `shouldReturn` []
443 it "Compose empty, empty" $
444 (tl (empty `f` empty)) `shouldReturn` []
445 it "Compose empty at the beginning" $
446 (tl $ (empty `f` return 1)) `shouldReturn` [1]
447 it "Compose empty at the end" $
448 (tl $ (return 1 `f` empty)) `shouldReturn` [1]
449 it "Compose two" $
450 (tl (return 0 `f` return 1) >>= return . srt)
451 `shouldReturn` [0, 1]
452 it "Compose three - empty in the middle" $
453 ((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt)
454 `shouldReturn` [0, 1]
455 it "Compose left associated" $
456 ((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
457 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
458 it "Compose right associated" $
459 ((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
460 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
461 it "Compose many" $
462 ((tl $ forEachWith f [1..100] return) >>= return . srt)
463 `shouldReturn` [1..100]
464 it "Compose hierarchical (multiple levels)" $
465 ((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
466 `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
467 ) >>= return . srt) `shouldReturn` [0..7]
468 where tl = toListSerial
470composeAndComposeSimple
471 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
472 -> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
473 -> [[Int]]
474 -> Spec
475composeAndComposeSimple f g answer = do
476 it "Compose right associated outer expr, right folded inner" $
477 let fold = foldMapWith g return
478 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
479 `shouldReturn` (answer !! 0)
481 it "Compose left associated outer expr, right folded inner" $
482 let fold = foldMapWith g return
483 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
484 `shouldReturn` (answer !! 1)
486 it "Compose right associated outer expr, left folded inner" $
487 let fold xs = foldl g empty $ map return xs
488 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
489 `shouldReturn` (answer !! 2)
491 it "Compose left associated outer expr, left folded inner" $
492 let fold xs = foldl g empty $ map return xs
493 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
494 `shouldReturn` (answer !! 3)
497loops
498 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
499 -> ([Int] -> [Int])
500 -> ([Int] -> [Int])
501 -> Spec
502loops f tsrt hsrt = do
503 it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt)
504 `shouldReturn` [0..3]
506 it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt)
507 `shouldReturn` [0..3]
509 where
510 loopHead x = do
511 -- this print line is important for the test (causes a bind)
512 liftIO $ putStrLn "LoopHead..."
513 (if x < 3 then loopHead (x + 1) else empty) `f` return x
515 loopTail x = do
516 -- this print line is important for the test (causes a bind)
517 liftIO $ putStrLn "LoopTail..."
518 return x `f` (if x < 3 then loopTail (x + 1) else empty)
520bindAndComposeSimple
521 :: (Streaming t, Alternative (t IO), Monad (t IO))
522 => (forall a. Ord a => t IO a -> IO [a])
523 -> (t IO Int -> t IO Int -> t IO Int)
524 -> Spec
525bindAndComposeSimple tl g = do
526 it "Compose many (right fold) with bind" $
527 (tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
528 >>= return . sort) `shouldReturn` [1..10]
530 it "Compose many (left fold) with bind" $
531 let forL xs k = foldl g empty $ map k xs
532 in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
533 >>= return . sort) `shouldReturn` [1..10]
534 where f = (>>=)
536bindAndComposeHierarchy
537 :: Monad (s IO) => (forall a. Ord a => s IO a -> IO [a])
538 -> ([s IO Int] -> s IO Int)
539 -> Spec
540bindAndComposeHierarchy tl g = do
541 it "Bind and compose nested" $
542 (tl bindComposeNested >>= return . sort)
543 `shouldReturn` (sort (
544 [12, 18]
545 ++ replicate 3 13
546 ++ replicate 3 17
547 ++ replicate 6 14
548 ++ replicate 6 16
549 ++ replicate 7 15) :: [Int])
551 where
553 -- bindComposeNested :: AsyncT IO Int
554 bindComposeNested =
555 let c1 = tripleCompose (return 1) (return 2) (return 3)
556 c2 = tripleCompose (return 4) (return 5) (return 6)
557 c3 = tripleCompose (return 7) (return 8) (return 9)
558 b = tripleBind c1 c2 c3
559-- it seems to be causing a huge space leak in hspec so disabling this for now
560-- c = tripleCompose b b b
561-- m = tripleBind c c c
562-- in m
563 in b
565 tripleCompose a b c = g [a, b, c]
566 tripleBind mx my mz =
567 mx `f` \x -> my
568 `f` \y -> mz
569 `f` \z -> return (x + y + z)
570 f = (>>=)
572mixedOps :: Spec
573mixedOps = do
574 it "Compose many ops" $
575 (toListSerial composeMixed >>= return . sort)
576 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
577 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
578 ] :: [Int])
579 where
581 composeMixed :: StreamT IO Int
582 composeMixed = do
583 liftIO $ return ()
584 liftIO $ putStr ""
585 x <- return 1
586 y <- return 2
587 z <- do
588 x1 <- return 1 <|> return 2
589 liftIO $ return ()
590 liftIO $ putStr ""
591 y1 <- return 1 <| return 2
592 z1 <- do
593 x11 <- return 1 <> return 2
594 y11 <- return 1 <| return 2
595 z11 <- return 1 <=> return 2
596 liftIO $ return ()
597 liftIO $ putStr ""
598 return (x11 + y11 + z11)
599 return (x1 + y1 + z1)
600 return (x + y + z)
602testListOp
603 :: (Streaming t, Monad (t IO))
604 => (t IO Int -> t IO Int -> t IO Int)
605 -> (t IO Int -> t IO Int)
606 -> ([Int] -> [Int])
607 -> Expectation
608testListOp f streamOp listOp =
609 let list = [1..10]
610 stream = foldMapWith f return list
611 in (A.toList $ streamOp stream) `shouldReturn` listOp list
613transformOps
614 :: (Streaming t, Monad (t IO))
615 => (t IO Int -> t IO Int -> t IO Int) -> Spec
616transformOps f = do
617 it "take all" $ testOp (A.take 10) (take 10)
618 it "take none" $ testOp (A.take 0) (take 0)
619 it "take 5" $ testOp (A.take 5) (take 5)
621 it "drop all" $ testOp (A.drop 10) (drop 10)
622 it "drop none" $ testOp (A.drop 0) (drop 0)
623 it "drop 5" $ testOp (A.drop 5) (drop 5)
625 it "dropWhile true" $ testOp (A.dropWhile (const True))
626 (dropWhile (const True))
627 it "dropWhile false" $ testOp (A.dropWhile (const False))
628 (dropWhile (const False))
629 it "dropWhile < 5" $ testOp (A.dropWhile (< 5)) (dropWhile (< 5))
631 it "filter all out" $ testOp (A.filter (> 10)) (filter (> 10))
632 it "filter all in" $ testOp (A.filter (<= 10)) (filter (<= 10))
633 it "filter even" $ testOp (A.filter even) (filter even)
635 where
636 testOp = testListOp f