git.iko.soy/streamly
on 29bc664 help sign in
streamly/test/Main.hs
710 lines 28 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE RankNTypes #-}
4module Main (main) where
6import Control.Concurrent (threadDelay)
7import Control.Monad (replicateM)
8import Data.Foldable (forM_)
9import Data.List (sort)
10import Test.Hspec
12import Streamly
13import qualified Streamly.Prelude as A
15toListSerial :: StreamT IO a -> IO [a]
16toListSerial = A.toList . serially
18toListInterleaved :: InterleavedT IO a -> IO [a]
19toListInterleaved = A.toList . interleaving
21toListAsync :: AsyncT IO a -> IO [a]
22toListAsync = A.toList . asyncly
24toListParallel :: Ord a => ParallelT IO a -> IO [a]
25toListParallel = fmap sort . A.toList . parallely
27main :: IO ()
28main = hspec $ do
29 describe "Runners" $ do
30 it "simple serially" $
31 (runStreaming . serially) (return (0 :: Int)) `shouldReturn` ()
32 it "simple serially with IO" $
33 (runStreaming . serially) (liftIO $ putStrLn "hello") `shouldReturn` ()
34 it "Captures a return value using toList" $
35 toListSerial (return 0) `shouldReturn` ([0] :: [Int])
37 describe "Empty" $ do
38 it "Monoid - mempty" $
39 (toListSerial mempty) `shouldReturn` ([] :: [Int])
40 it "Alternative - empty" $
41 (toListSerial empty) `shouldReturn` ([] :: [Int])
42 it "MonadPlus - mzero" $
43 (toListSerial mzero) `shouldReturn` ([] :: [Int])
45 ---------------------------------------------------------------------------
46 -- Functor
47 ---------------------------------------------------------------------------
49 describe "Functor (fmap)" $ do
50 it "Simple fmap" $
51 (toListSerial $ fmap (+1) (return 1)) `shouldReturn` ([2] :: [Int])
52 it "fmap on composed (<>)" $
53 (toListSerial $ fmap (+1) (return 1 <> return 2))
54 `shouldReturn` ([2,3] :: [Int])
55 it "fmap on composed (<|>)" $
56 (toListSerial $ fmap (+1) (return 1 <|> return 2))
57 `shouldReturn` ([2,3] :: [Int])
59 ---------------------------------------------------------------------------
60 -- Applicative
61 ---------------------------------------------------------------------------
63 describe "Applicative" $ do
64 it "Simple apply" $
65 (toListSerial $ (,) <$> (return 1) <*> (return 2))
66 `shouldReturn` ([(1,2)] :: [(Int, Int)])
68 it "Apply - serial composed first argument" $
69 (toListSerial $ (,) <$> (return 1 <> return 2) <*> (return 3))
70 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
72 it "Apply - serial composed second argument" $
73 (toListSerial $ (,) <$> (return 1) <*> (return 2 <> return 3))
74 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
76 it "Apply - parallel composed first argument" $
77 (toListSerial $ (,) <$> (return 1 <|> return 2) <*> (return 3))
78 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
80 it "Apply - parallel composed second argument" $
81 (toListSerial $ (,) <$> (return 1) <*> (return 2 <|> return 3))
82 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
84 ---------------------------------------------------------------------------
85 -- Binds
86 ---------------------------------------------------------------------------
88 describe "Bind then" thenBind
89 describe "Pure bind serial" $ pureBind toListSerial
90 describe "Pure bind serial interleaved" $ pureBind toListInterleaved
91 describe "Pure bind parallel DFS" $ pureBind toListAsync
92 describe "Pure bind parallel BFS" $ pureBind toListParallel
94 describe "Bind (>>=) with empty" $ bindEmpty toListSerial
95 describe "Bind (>->) with empty" $ bindEmpty toListInterleaved
96 describe "Bind (>|>) with empty" $ bindEmpty toListAsync
97 describe "Bind (>>|) with empty" $ bindEmpty toListParallel
99 ---------------------------------------------------------------------------
100 -- Monoidal Compositions
101 ---------------------------------------------------------------------------
103 describe "Serial Composition (<>)" $ compose (<>) id
104 describe "Serial Composition (mappend)" $ compose mappend id
105 describe "Interleaved Composition (<>)" $ compose (<=>) sort
106 describe "Left biased parallel Composition (<|)" $ compose (<|) sort
107 describe "Fair parallel Composition (<|>)" $ compose (<|>) sort
108 describe "Fair parallel Composition (mplus)" $ compose mplus sort
110 ---------------------------------------------------------------------------
111 -- Monoidal Composition ordering checks
112 ---------------------------------------------------------------------------
114 describe "Serial interleaved ordering check (<=>)" $ interleaveCheck (<=>)
115 describe "Parallel interleaved ordering check (<|>)" $ interleaveCheck (<|>)
116 describe "Left biased parallel time order check" $ parallelCheck (<|)
117 describe "Fair parallel time order check" $ parallelCheck (<|>)
119 ---------------------------------------------------------------------------
120 -- TBD Monoidal composition combinations
121 ---------------------------------------------------------------------------
123 -- TBD need more such combinations to be tested.
124 describe "<> and <>" $ composeAndComposeSimple (<>) (<>) (cycle [[1 .. 9]])
126 describe "<> and <=>" $ composeAndComposeSimple
127 (<>)
128 (<=>)
129 ([ [1 .. 9]
130 , [1 .. 9]
131 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
132 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
133 ])
135 describe "<=> and <=>" $ composeAndComposeSimple
136 (<=>)
137 (<=>)
138 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
139 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
140 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
141 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
142 ])
144 describe "<=> and <>" $ composeAndComposeSimple
145 (<=>)
146 (<>)
147 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
148 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
149 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
150 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
151 ])
153 describe "Nested parallel and serial compositions" $ do
154 {-
155 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
156 -- because of parallelism of [8,0] and [8,0].
157 it "Nest <|>, <>, <|> (1)" $
158 let t = timed
159 in toListSerial (
160 ((t 8 <|> t 4) <> (t 2 <|> t 0))
161 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
162 `shouldReturn` ([4,4,8,8,0,0,2,2])
163 -}
164 it "Nest <|>, <>, <|> (2)" $
165 let t = timed
166 in toListSerial (
167 ((t 4 <|> t 8) <> (t 1 <|> t 2))
168 <|> ((t 4 <|> t 8) <> (t 1 <|> t 2)))
169 `shouldReturn` ([4,4,8,8,1,1,2,2])
170 -- FIXME: These two keep failing intermittently on Mac OS X
171 -- Need to examine and fix the tests.
172 {-
173 it "Nest <|>, <=>, <|> (1)" $
174 let t = timed
175 in toListSerial (
176 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
177 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
178 `shouldReturn` ([4,4,0,0,8,2,9,2])
179 it "Nest <|>, <=>, <|> (2)" $
180 let t = timed
181 in toListSerial (
182 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
183 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
184 `shouldReturn` ([4,4,1,1,8,2,9,2])
185 -}
186 it "Nest <|>, <|>, <|>" $
187 let t = timed
188 in toListSerial (
189 ((t 4 <|> t 8) <|> (t 0 <|> t 2))
190 <|> ((t 4 <|> t 8) <|> (t 0 <|> t 2)))
191 `shouldReturn` ([0,0,2,2,4,4,8,8])
193 ---------------------------------------------------------------------------
194 -- Monoidal composition recursion loops
195 ---------------------------------------------------------------------------
197 describe "Serial loops (<>)" $ loops (<>) id reverse
198 describe "Left biased parallel loops (<|)" $ loops (<|) sort sort
199 describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort
201 ---------------------------------------------------------------------------
202 -- Bind and monoidal composition combinations
203 ---------------------------------------------------------------------------
205 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
206 describe "Bind and compose" $ bindAndComposeSimple toListSerial g
208 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
209 describe "Bind and compose" $ bindAndComposeSimple toListInterleaved g
211 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
212 describe "Bind and compose" $ bindAndComposeSimple toListAsync g
214 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
215 describe "Bind and compose" $ bindAndComposeSimple toListParallel g
217 let fldr f = foldr f empty
218 fldl f = foldl f empty
219 in do
220 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
221 forM_ [fldr, fldl] $ \k ->
222 describe "Bind and compose" $
223 bindAndComposeHierarchy toListSerial (k g)
224 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
225 forM_ [fldr, fldl] $ \k ->
226 describe "Bind and compose" $
227 bindAndComposeHierarchy toListInterleaved (k g)
228 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
229 forM_ [fldr, fldl] $ \k ->
230 describe "Bind and compose" $
231 bindAndComposeHierarchy toListAsync (k g)
232 forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
233 forM_ [fldr, fldl] $ \k ->
234 describe "Bind and compose" $
235 bindAndComposeHierarchy toListParallel (k g)
237 -- Nest two lists using different styles of product compositions
238 it "Nests two streams using monadic serial composition" nestTwoSerial
239 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
240 it "Nests two streams using monadic async composition" nestTwoAsync
241 it "Nests two streams using monadic parallel composition" nestTwoParallel
243 it "Nests two streams using applicative serial composition" nestTwoSerialApp
244 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
245 it "Nests two streams using applicative async composition" nestTwoAsyncApp
246 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
248 it "Nests two streams using Num serial composition" nestTwoSerialNum
249 it "Nests two streams using Num interleaved composition" nestTwoInterleavedNum
250 it "Nests two streams using Num async composition" nestTwoAsyncNum
251 -- This test fails intermittently, need to investigate
252 -- it "Nests two streams using Num parallel composition" nestTwoParallelNum
254 ---------------------------------------------------------------------------
255 -- TBD Bind and Bind combinations
256 ---------------------------------------------------------------------------
258 -- TBD combine all binds and all compose in one example
259 describe "Miscellaneous combined examples" mixedOps
261 ---------------------------------------------------------------------------
262 -- Stream operations
263 ---------------------------------------------------------------------------
265 -- XXX for streams other than StreamT
266 describe "Stream Ops empty" $ streamOperations makeEmptyStream
267 describe "Stream ops singleton constr" $ streamOperations makeSingletonStream1
268 describe "Stream ops singleton folded" $ streamOperations makeSingletonStream2
269 describe "Stream Ops constr" $ streamOperations makeStream1
270 describe "Stream Ops folded" $ streamOperations $ makeStream2
271 ((<>) :: StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
273 describe "Serial zipping" $
274 zipOps A.zipWith A.zipWithM zipping
275 describe "Async zipping" $
276 zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync
278makeEmptyStream :: (StreamT IO Int, [Int], Int)
279makeEmptyStream = (A.nil, [], 0)
281makeSingletonStream1 :: (StreamT IO Int, [Int], Int)
282makeSingletonStream1 = (1 `A.cons` A.nil, [1], 1)
284makeSingletonStream2 :: (StreamT IO Int, [Int], Int)
285makeSingletonStream2 = (return 1, [1], 1)
287-- Streams that indicate an end via the stop continuation
288makeStream1 :: (StreamT IO Int, [Int], Int)
289makeStream1 =
290 let list = [1..10]
291 stream = A.each list
292 in (stream, list, 10)
294-- Streams that indicate an end via the yield continuation
295makeStream2 :: (Streaming t, Monad (t IO))
296 => (t IO Int -> t IO Int -> t IO Int)
297 -> (t IO Int, [Int], Int)
298makeStream2 f =
299 let list = [1..10]
300 stream = foldMapWith f return list
301 in (stream, list, 10)
303nestTwoSerial :: Expectation
304nestTwoSerial =
305 let s1 = foldMapWith (<>) return [1..4]
306 s2 = foldMapWith (<>) return [5..8]
307 in toListSerial (do
308 x <- s1
309 y <- s2
310 return (x + y)
311 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
313nestTwoSerialApp :: Expectation
314nestTwoSerialApp =
315 let s1 = foldMapWith (<>) return [1..4]
316 s2 = foldMapWith (<>) return [5..8]
317 in toListSerial ((+) <$> s1 <*> s2)
318 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
320nestTwoSerialNum :: Expectation
321nestTwoSerialNum =
322 let s1 = foldMapWith (<>) return [1..4]
323 s2 = foldMapWith (<>) return [5..8]
324 in toListSerial (s1 + s2)
325 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
327nestTwoInterleaved :: Expectation
328nestTwoInterleaved =
329 let s1 = foldMapWith (<>) return [1..4]
330 s2 = foldMapWith (<>) return [5..8]
331 in toListInterleaved (do
332 x <- s1
333 y <- s2
334 return (x + y)
335 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
337nestTwoInterleavedApp :: Expectation
338nestTwoInterleavedApp =
339 let s1 = foldMapWith (<>) return [1..4]
340 s2 = foldMapWith (<>) return [5..8]
341 in toListInterleaved ((+) <$> s1 <*> s2)
342 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
344nestTwoInterleavedNum :: Expectation
345nestTwoInterleavedNum =
346 let s1 = foldMapWith (<>) return [1..4]
347 s2 = foldMapWith (<>) return [5..8]
348 in toListInterleaved (s1 + s2)
349 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
351nestTwoAsync :: Expectation
352nestTwoAsync =
353 let s1 = foldMapWith (<>) return [1..4]
354 s2 = foldMapWith (<>) return [5..8]
355 in toListAsync (do
356 x <- s1
357 y <- s2
358 return (x + y)
359 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
361nestTwoAsyncApp :: Expectation
362nestTwoAsyncApp =
363 let s1 = foldMapWith (<>) return [1..4]
364 s2 = foldMapWith (<>) return [5..8]
365 in toListAsync ((+) <$> s1 <*> s2)
366 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
368nestTwoAsyncNum :: Expectation
369nestTwoAsyncNum =
370 let s1 = foldMapWith (<>) return [1..4]
371 s2 = foldMapWith (<>) return [5..8]
372 in toListAsync (s1 + s2)
373 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
375nestTwoParallel :: Expectation
376nestTwoParallel =
377 let s1 = foldMapWith (<>) return [1..4]
378 s2 = foldMapWith (<>) return [5..8]
379 in toListParallel (do
380 x <- s1
381 y <- s2
382 return (x + y)
383 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
385nestTwoParallelApp :: Expectation
386nestTwoParallelApp =
387 let s1 = foldMapWith (<>) return [1..4]
388 s2 = foldMapWith (<>) return [5..8]
389 in toListParallel ((+) <$> s1 <*> s2)
390 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
392{-
393nestTwoParallelNum :: Expectation
394nestTwoParallelNum =
395 let s1 = foldMapWith (<>) return [1..4]
396 s2 = foldMapWith (<>) return [5..8]
397 in toListParallel (s1 + s2)
398 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
399-}
401zipOps :: (Streaming t, Applicative (t IO))
402 => (forall a b c. (a -> b -> c)
403 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
404 -> (forall a b c. (a -> b -> StreamT IO c)
405 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
406 -> (forall a. t IO a -> t IO a)
407 -> Spec
408zipOps z zM app = do
409 it "zipWith" $
410 let s1 = foldMapWith (<>) return [1..10]
411 s2 = foldMapWith (<>) return [1..]
412 in toListSerial (z (+) s1 s2)
413 `shouldReturn` ([2,4..20] :: [Int])
415 it "zipWithM" $
416 let s1 = foldMapWith (<>) return [1..10]
417 s2 = foldMapWith (<>) return [1..]
418 in toListSerial (zM (\a b -> return (a + b)) s1 s2)
419 `shouldReturn` ([2,4..20] :: [Int])
421 it "Applicative zip" $
422 let s1 = adapt $ serially $ foldMapWith (<>) return [1..10]
423 s2 = adapt $ serially $ foldMapWith (<>) return [1..]
424 in (A.toList . app) ((+) <$> s1 <*> s2)
425 `shouldReturn` ([2,4..20] :: [Int])
427timed :: Int -> StreamT IO Int
428timed x = liftIO (threadDelay (x * 100000)) >> return x
430thenBind :: Spec
431thenBind = do
432 it "Simple runStreaming and 'then' with IO" $
433 (runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
434 `shouldReturn` ()
435 it "Then and toList" $
436 toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
438type ToListType s = (forall a. Ord a => s IO a -> IO [a])
439pureBind :: Monad (s IO) => ToListType s -> Spec
440pureBind l = do
441 it "Bind and toList" $
442 l (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
443 `shouldReturn` ([3] :: [Int])
444 where f = (>>=)
446bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec
447bindEmpty l = it "Binds with empty" $
448 (l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2))
449 `shouldReturn` ([] :: [Int])
450 where f = (>>=)
452interleaveCheck
453 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
454 -> Spec
455interleaveCheck f =
456 it "Interleave four" $
457 toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101))
458 `shouldReturn` ([0, 100, 1, 101])
460parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
461parallelCheck f = do
462 it "Parallel ordering left associated" $
463 toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1)
464 `shouldReturn` ([1..4])
466 it "Parallel ordering right associated" $
467 toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
468 `shouldReturn` ([1..4])
470 where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
472compose
473 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
474 -> ([Int] -> [Int])
475 -> Spec
476compose f srt = do
477 it "Compose mempty, mempty" $
478 (tl (mempty `f` mempty)) `shouldReturn` []
479 it "Compose empty, empty" $
480 (tl (empty `f` empty)) `shouldReturn` []
481 it "Compose empty at the beginning" $
482 (tl $ (empty `f` return 1)) `shouldReturn` [1]
483 it "Compose empty at the end" $
484 (tl $ (return 1 `f` empty)) `shouldReturn` [1]
485 it "Compose two" $
486 (tl (return 0 `f` return 1) >>= return . srt)
487 `shouldReturn` [0, 1]
488 it "Compose three - empty in the middle" $
489 ((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt)
490 `shouldReturn` [0, 1]
491 it "Compose left associated" $
492 ((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
493 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
494 it "Compose right associated" $
495 ((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
496 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
497 it "Compose many" $
498 ((tl $ forEachWith f [1..100] return) >>= return . srt)
499 `shouldReturn` [1..100]
500 it "Compose hierarchical (multiple levels)" $
501 ((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
502 `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
503 ) >>= return . srt) `shouldReturn` [0..7]
504 where tl = toListSerial
506composeAndComposeSimple
507 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
508 -> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
509 -> [[Int]]
510 -> Spec
511composeAndComposeSimple f g answer = do
512 it "Compose right associated outer expr, right folded inner" $
513 let fold = foldMapWith g return
514 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
515 `shouldReturn` (answer !! 0)
517 it "Compose left associated outer expr, right folded inner" $
518 let fold = foldMapWith g return
519 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
520 `shouldReturn` (answer !! 1)
522 it "Compose right associated outer expr, left folded inner" $
523 let fold xs = foldl g empty $ map return xs
524 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
525 `shouldReturn` (answer !! 2)
527 it "Compose left associated outer expr, left folded inner" $
528 let fold xs = foldl g empty $ map return xs
529 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
530 `shouldReturn` (answer !! 3)
533loops
534 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
535 -> ([Int] -> [Int])
536 -> ([Int] -> [Int])
537 -> Spec
538loops f tsrt hsrt = do
539 it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt)
540 `shouldReturn` [0..3]
542 it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt)
543 `shouldReturn` [0..3]
545 where
546 loopHead x = do
547 -- this print line is important for the test (causes a bind)
548 liftIO $ putStrLn "LoopHead..."
549 (if x < 3 then loopHead (x + 1) else empty) `f` return x
551 loopTail x = do
552 -- this print line is important for the test (causes a bind)
553 liftIO $ putStrLn "LoopTail..."
554 return x `f` (if x < 3 then loopTail (x + 1) else empty)
556bindAndComposeSimple
557 :: (Streaming t, Alternative (t IO), Monad (t IO))
558 => (forall a. Ord a => t IO a -> IO [a])
559 -> (t IO Int -> t IO Int -> t IO Int)
560 -> Spec
561bindAndComposeSimple tl g = do
562 it "Compose many (right fold) with bind" $
563 (tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
564 >>= return . sort) `shouldReturn` [1..10]
566 it "Compose many (left fold) with bind" $
567 let forL xs k = foldl g empty $ map k xs
568 in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
569 >>= return . sort) `shouldReturn` [1..10]
570 where f = (>>=)
572bindAndComposeHierarchy
573 :: Monad (s IO) => (forall a. Ord a => s IO a -> IO [a])
574 -> ([s IO Int] -> s IO Int)
575 -> Spec
576bindAndComposeHierarchy tl g = do
577 it "Bind and compose nested" $
578 (tl bindComposeNested >>= return . sort)
579 `shouldReturn` (sort (
580 [12, 18]
581 ++ replicate 3 13
582 ++ replicate 3 17
583 ++ replicate 6 14
584 ++ replicate 6 16
585 ++ replicate 7 15) :: [Int])
587 where
589 -- bindComposeNested :: AsyncT IO Int
590 bindComposeNested =
591 let c1 = tripleCompose (return 1) (return 2) (return 3)
592 c2 = tripleCompose (return 4) (return 5) (return 6)
593 c3 = tripleCompose (return 7) (return 8) (return 9)
594 b = tripleBind c1 c2 c3
595-- it seems to be causing a huge space leak in hspec so disabling this for now
596-- c = tripleCompose b b b
597-- m = tripleBind c c c
598-- in m
599 in b
601 tripleCompose a b c = g [a, b, c]
602 tripleBind mx my mz =
603 mx `f` \x -> my
604 `f` \y -> mz
605 `f` \z -> return (x + y + z)
606 f = (>>=)
608mixedOps :: Spec
609mixedOps = do
610 it "Compose many ops" $
611 (toListSerial composeMixed >>= return . sort)
612 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
613 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
614 ] :: [Int])
615 where
617 composeMixed :: StreamT IO Int
618 composeMixed = do
619 liftIO $ return ()
620 liftIO $ putStr ""
621 x <- return 1
622 y <- return 2
623 z <- do
624 x1 <- return 1 <|> return 2
625 liftIO $ return ()
626 liftIO $ putStr ""
627 y1 <- return 1 <| return 2
628 z1 <- do
629 x11 <- return 1 <> return 2
630 y11 <- return 1 <| return 2
631 z11 <- return 1 <=> return 2
632 liftIO $ return ()
633 liftIO $ putStr ""
634 return (x11 + y11 + z11)
635 return (x1 + y1 + z1)
636 return (x + y + z)
638streamOperations :: Streaming t => (t IO Int, [Int], Int) -> Spec
639streamOperations (stream, list, len) = do
641 -- Generation
642 it "replicateM" $ do
643 let x = return (1 :: Int)
644 str <- A.toList . serially $ A.replicateM len x
645 lst <- replicateM len x
646 return $ str == lst
647 `shouldReturn` True
649 -- Filtering
650 it "filter all out" $ transform (A.filter (> len)) (filter (> len))
651 it "filter all in" $ transform (A.filter (<= len)) (filter (<= len))
652 it "filter even" $ transform (A.filter even) (filter even)
654 it "take all" $ transform (A.take len) (take len)
655 it "take none" $ transform (A.take 0) (take 0)
656 it "take some" $ transform (A.take $ len - 1) (take $ len - 1)
657 it "take one" $ transform (A.take 1) (take 1)
659 it "takeWhile true" $ transform (A.takeWhile (const True))
660 (takeWhile (const True))
661 it "takeWhile false" $ transform (A.takeWhile (const False))
662 (takeWhile (const False))
663 it "takeWhile < some" $ transform (A.takeWhile (< (len `div` 2)))
664 (takeWhile (< (len `div` 2)))
666 it "drop all" $ transform (A.drop len) (drop len)
667 it "drop none" $ transform (A.drop 0) (drop 0)
668 it "drop some" $ transform (A.drop $ len - 1) (drop $ len - 1)
669 it "drop one" $ transform (A.drop 1) (drop 1)
671 it "dropWhile true" $ transform (A.dropWhile (const True))
672 (dropWhile (const True))
673 it "dropWhile false" $ transform (A.dropWhile (const False))
674 (dropWhile (const False))
675 it "dropWhile < some" $ transform (A.dropWhile (< (len `div` 2)))
676 (dropWhile (< (len `div` 2)))
678 it "scan left" $ transform (A.scan (+) 0 id) (scanl (+) 0)
680 -- Elimination
681 it "foldl" $ elimination (A.foldl (+) 0 id) (foldl (+) 0)
682 it "all" $ elimination (A.all even) (all even)
683 it "any" $ elimination (A.any even) (any even)
684 it "length" $ elimination A.length length
685 it "elem" $ elimination (A.elem (len - 1)) (elem (len - 1))
686 it "elem" $ elimination (A.elem (len + 1)) (elem (len + 1))
687 it "notElem" $ elimination (A.notElem (len - 1)) (notElem (len - 1))
688 it "notElem" $ elimination (A.notElem (len + 1)) (notElem (len + 1))
689 it "sum" $ elimination A.sum sum
690 it "product" $ elimination A.product product
692 if list == []
693 then do
694 it "head empty" $ A.head stream `shouldReturn` Nothing
695 it "last empty" $ A.last stream `shouldReturn` Nothing
696 it "maximum empty" $ A.maximum stream `shouldReturn` Nothing
697 it "minimum empty" $ A.minimum stream `shouldReturn` Nothing
698 else do
699 it "head nonEmpty" $ A.head stream `shouldReturn` Just (head list)
700 it "last nonEmpty" $ A.last stream `shouldReturn` Just (last list)
701 it "maximum nonEmpty" $ A.maximum stream `shouldReturn` Just (maximum list)
702 it "minimum nonEmpty" $ A.minimum stream `shouldReturn` Just (minimum list)
704 where
706 -- XXX run on empty stream as well
707 transform streamOp listOp =
708 (A.toList $ streamOp stream) `shouldReturn` listOp list
710 elimination streamOp listOp = (streamOp stream) `shouldReturn` listOp list