git.iko.soy/streamly
on 78f2ec8 help sign in
streamly/test/Main.hs
701 lines 28 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 ---------------------------------------------------------------------------
261 -- Stream operations
262 ---------------------------------------------------------------------------
264 -- XXX for streams other than StreamT
265 describe "Stream Ops empty" $ streamOperations makeEmptyStream
266 describe "Stream ops singleton constr" $ streamOperations makeSingletonStream1
267 describe "Stream ops singleton folded" $ streamOperations makeSingletonStream2
268 describe "Stream Ops constr" $ streamOperations makeStream1
269 describe "Stream Ops folded" $ streamOperations $ makeStream2
270 ((<>) :: StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
272 describe "Serial zipping" $
273 zipOps A.zipWith A.zipWithM zipping
274 describe "Async zipping" $
275 zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync
277makeEmptyStream :: (StreamT IO Int, [Int], Int)
278makeEmptyStream = (A.nil, [], 0)
280makeSingletonStream1 :: (StreamT IO Int, [Int], Int)
281makeSingletonStream1 = (1 `A.cons` A.nil, [1], 1)
283makeSingletonStream2 :: (StreamT IO Int, [Int], Int)
284makeSingletonStream2 = (return 1, [1], 1)
286-- Streams that indicate an end via the stop continuation
287makeStream1 :: (StreamT IO Int, [Int], Int)
288makeStream1 =
289 let list = [1..10]
290 stream = A.each list
291 in (stream, list, 10)
293-- Streams that indicate an end via the yield continuation
294makeStream2 :: (Streaming t, Monad (t IO))
295 => (t IO Int -> t IO Int -> t IO Int)
296 -> (t IO Int, [Int], Int)
297makeStream2 f =
298 let list = [1..10]
299 stream = foldMapWith f return list
300 in (stream, list, 10)
302nestTwoSerial :: Expectation
303nestTwoSerial =
304 let s1 = foldMapWith (<>) return [1..4]
305 s2 = foldMapWith (<>) return [5..8]
306 in toListSerial (do
307 x <- s1
308 y <- s2
309 return (x + y)
310 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
312nestTwoSerialApp :: Expectation
313nestTwoSerialApp =
314 let s1 = foldMapWith (<>) return [1..4]
315 s2 = foldMapWith (<>) return [5..8]
316 in toListSerial ((+) <$> s1 <*> s2)
317 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
319nestTwoSerialNum :: Expectation
320nestTwoSerialNum =
321 let s1 = foldMapWith (<>) return [1..4]
322 s2 = foldMapWith (<>) return [5..8]
323 in toListSerial (s1 + s2)
324 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
326nestTwoInterleaved :: Expectation
327nestTwoInterleaved =
328 let s1 = foldMapWith (<>) return [1..4]
329 s2 = foldMapWith (<>) return [5..8]
330 in toListInterleaved (do
331 x <- s1
332 y <- s2
333 return (x + y)
334 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
336nestTwoInterleavedApp :: Expectation
337nestTwoInterleavedApp =
338 let s1 = foldMapWith (<>) return [1..4]
339 s2 = foldMapWith (<>) return [5..8]
340 in toListInterleaved ((+) <$> s1 <*> s2)
341 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
343nestTwoInterleavedNum :: Expectation
344nestTwoInterleavedNum =
345 let s1 = foldMapWith (<>) return [1..4]
346 s2 = foldMapWith (<>) return [5..8]
347 in toListInterleaved (s1 + s2)
348 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
350nestTwoAsync :: Expectation
351nestTwoAsync =
352 let s1 = foldMapWith (<>) return [1..4]
353 s2 = foldMapWith (<>) return [5..8]
354 in toListAsync (do
355 x <- s1
356 y <- s2
357 return (x + y)
358 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
360nestTwoAsyncApp :: Expectation
361nestTwoAsyncApp =
362 let s1 = foldMapWith (<>) return [1..4]
363 s2 = foldMapWith (<>) return [5..8]
364 in toListAsync ((+) <$> s1 <*> s2)
365 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
367nestTwoAsyncNum :: Expectation
368nestTwoAsyncNum =
369 let s1 = foldMapWith (<>) return [1..4]
370 s2 = foldMapWith (<>) return [5..8]
371 in toListAsync (s1 + s2)
372 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
374nestTwoParallel :: Expectation
375nestTwoParallel =
376 let s1 = foldMapWith (<>) return [1..4]
377 s2 = foldMapWith (<>) return [5..8]
378 in toListParallel (do
379 x <- s1
380 y <- s2
381 return (x + y)
382 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
384nestTwoParallelApp :: Expectation
385nestTwoParallelApp =
386 let s1 = foldMapWith (<>) return [1..4]
387 s2 = foldMapWith (<>) return [5..8]
388 in toListParallel ((+) <$> s1 <*> s2)
389 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
391{-
392nestTwoParallelNum :: Expectation
393nestTwoParallelNum =
394 let s1 = foldMapWith (<>) return [1..4]
395 s2 = foldMapWith (<>) return [5..8]
396 in toListParallel (s1 + s2)
397 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
398-}
400zipOps :: (Streaming t, Applicative (t IO))
401 => (forall a b c. (a -> b -> c)
402 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
403 -> (forall a b c. (a -> b -> StreamT IO c)
404 -> StreamT IO a -> StreamT IO b -> StreamT IO c)
405 -> (forall a. t IO a -> t IO a)
406 -> Spec
407zipOps z zM app = do
408 it "zipWith" $
409 let s1 = foldMapWith (<>) return [1..10]
410 s2 = foldMapWith (<>) return [1..]
411 in toListSerial (z (+) s1 s2)
412 `shouldReturn` ([2,4..20] :: [Int])
414 it "zipWithM" $
415 let s1 = foldMapWith (<>) return [1..10]
416 s2 = foldMapWith (<>) return [1..]
417 in toListSerial (zM (\a b -> return (a + b)) s1 s2)
418 `shouldReturn` ([2,4..20] :: [Int])
420 it "Applicative zip" $
421 let s1 = adapt $ serially $ foldMapWith (<>) return [1..10]
422 s2 = adapt $ serially $ foldMapWith (<>) return [1..]
423 in (A.toList . app) ((+) <$> s1 <*> s2)
424 `shouldReturn` ([2,4..20] :: [Int])
426timed :: Int -> StreamT IO Int
427timed x = liftIO (threadDelay (x * 100000)) >> return x
429thenBind :: Spec
430thenBind = do
431 it "Simple runStreaming and 'then' with IO" $
432 (runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
433 `shouldReturn` ()
434 it "Then and toList" $
435 toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
437type ToListType s = (forall a. Ord a => s IO a -> IO [a])
438pureBind :: Monad (s IO) => ToListType s -> Spec
439pureBind l = do
440 it "Bind and toList" $
441 l (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
442 `shouldReturn` ([3] :: [Int])
443 where f = (>>=)
445bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec
446bindEmpty l = it "Binds with empty" $
447 (l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2))
448 `shouldReturn` ([] :: [Int])
449 where f = (>>=)
451interleaveCheck
452 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
453 -> Spec
454interleaveCheck f =
455 it "Interleave four" $
456 toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101))
457 `shouldReturn` ([0, 100, 1, 101])
459parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
460parallelCheck f = do
461 it "Parallel ordering left associated" $
462 toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1)
463 `shouldReturn` ([1..4])
465 it "Parallel ordering right associated" $
466 toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
467 `shouldReturn` ([1..4])
469 where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
471compose
472 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
473 -> ([Int] -> [Int])
474 -> Spec
475compose f srt = do
476 it "Compose mempty, mempty" $
477 (tl (mempty `f` mempty)) `shouldReturn` []
478 it "Compose empty, empty" $
479 (tl (empty `f` empty)) `shouldReturn` []
480 it "Compose empty at the beginning" $
481 (tl $ (empty `f` return 1)) `shouldReturn` [1]
482 it "Compose empty at the end" $
483 (tl $ (return 1 `f` empty)) `shouldReturn` [1]
484 it "Compose two" $
485 (tl (return 0 `f` return 1) >>= return . srt)
486 `shouldReturn` [0, 1]
487 it "Compose three - empty in the middle" $
488 ((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt)
489 `shouldReturn` [0, 1]
490 it "Compose left associated" $
491 ((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
492 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
493 it "Compose right associated" $
494 ((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
495 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
496 it "Compose many" $
497 ((tl $ forEachWith f [1..100] return) >>= return . srt)
498 `shouldReturn` [1..100]
499 it "Compose hierarchical (multiple levels)" $
500 ((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
501 `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
502 ) >>= return . srt) `shouldReturn` [0..7]
503 where tl = toListSerial
505composeAndComposeSimple
506 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
507 -> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
508 -> [[Int]]
509 -> Spec
510composeAndComposeSimple f g answer = do
511 it "Compose right associated outer expr, right folded inner" $
512 let fold = foldMapWith g return
513 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
514 `shouldReturn` (answer !! 0)
516 it "Compose left associated outer expr, right folded inner" $
517 let fold = foldMapWith g return
518 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
519 `shouldReturn` (answer !! 1)
521 it "Compose right associated outer expr, left folded inner" $
522 let fold xs = foldl g empty $ map return xs
523 in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
524 `shouldReturn` (answer !! 2)
526 it "Compose left associated outer expr, left folded inner" $
527 let fold xs = foldl g empty $ map return xs
528 in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
529 `shouldReturn` (answer !! 3)
532loops
533 :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
534 -> ([Int] -> [Int])
535 -> ([Int] -> [Int])
536 -> Spec
537loops f tsrt hsrt = do
538 it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt)
539 `shouldReturn` [0..3]
541 it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt)
542 `shouldReturn` [0..3]
544 where
545 loopHead x = do
546 -- this print line is important for the test (causes a bind)
547 liftIO $ putStrLn "LoopHead..."
548 (if x < 3 then loopHead (x + 1) else empty) `f` return x
550 loopTail x = do
551 -- this print line is important for the test (causes a bind)
552 liftIO $ putStrLn "LoopTail..."
553 return x `f` (if x < 3 then loopTail (x + 1) else empty)
555bindAndComposeSimple
556 :: (Streaming t, Alternative (t IO), Monad (t IO))
557 => (forall a. Ord a => t IO a -> IO [a])
558 -> (t IO Int -> t IO Int -> t IO Int)
559 -> Spec
560bindAndComposeSimple tl g = do
561 it "Compose many (right fold) with bind" $
562 (tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
563 >>= return . sort) `shouldReturn` [1..10]
565 it "Compose many (left fold) with bind" $
566 let forL xs k = foldl g empty $ map k xs
567 in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
568 >>= return . sort) `shouldReturn` [1..10]
569 where f = (>>=)
571bindAndComposeHierarchy
572 :: Monad (s IO) => (forall a. Ord a => s IO a -> IO [a])
573 -> ([s IO Int] -> s IO Int)
574 -> Spec
575bindAndComposeHierarchy tl g = do
576 it "Bind and compose nested" $
577 (tl bindComposeNested >>= return . sort)
578 `shouldReturn` (sort (
579 [12, 18]
580 ++ replicate 3 13
581 ++ replicate 3 17
582 ++ replicate 6 14
583 ++ replicate 6 16
584 ++ replicate 7 15) :: [Int])
586 where
588 -- bindComposeNested :: AsyncT IO Int
589 bindComposeNested =
590 let c1 = tripleCompose (return 1) (return 2) (return 3)
591 c2 = tripleCompose (return 4) (return 5) (return 6)
592 c3 = tripleCompose (return 7) (return 8) (return 9)
593 b = tripleBind c1 c2 c3
594-- it seems to be causing a huge space leak in hspec so disabling this for now
595-- c = tripleCompose b b b
596-- m = tripleBind c c c
597-- in m
598 in b
600 tripleCompose a b c = g [a, b, c]
601 tripleBind mx my mz =
602 mx `f` \x -> my
603 `f` \y -> mz
604 `f` \z -> return (x + y + z)
605 f = (>>=)
607mixedOps :: Spec
608mixedOps = do
609 it "Compose many ops" $
610 (toListSerial composeMixed >>= return . sort)
611 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
612 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
613 ] :: [Int])
614 where
616 composeMixed :: StreamT IO Int
617 composeMixed = do
618 liftIO $ return ()
619 liftIO $ putStr ""
620 x <- return 1
621 y <- return 2
622 z <- do
623 x1 <- return 1 <|> return 2
624 liftIO $ return ()
625 liftIO $ putStr ""
626 y1 <- return 1 <| return 2
627 z1 <- do
628 x11 <- return 1 <> return 2
629 y11 <- return 1 <| return 2
630 z11 <- return 1 <=> return 2
631 liftIO $ return ()
632 liftIO $ putStr ""
633 return (x11 + y11 + z11)
634 return (x1 + y1 + z1)
635 return (x + y + z)
637streamOperations :: Streaming t => (t IO Int, [Int], Int) -> Spec
638streamOperations (stream, list, len) = do
640 -- Filtering
641 it "filter all out" $ transform (A.filter (> len)) (filter (> len))
642 it "filter all in" $ transform (A.filter (<= len)) (filter (<= len))
643 it "filter even" $ transform (A.filter even) (filter even)
645 it "take all" $ transform (A.take len) (take len)
646 it "take none" $ transform (A.take 0) (take 0)
647 it "take some" $ transform (A.take $ len - 1) (take $ len - 1)
648 it "take one" $ transform (A.take 1) (take 1)
650 it "takeWhile true" $ transform (A.takeWhile (const True))
651 (takeWhile (const True))
652 it "takeWhile false" $ transform (A.takeWhile (const False))
653 (takeWhile (const False))
654 it "takeWhile < some" $ transform (A.takeWhile (< (len `div` 2)))
655 (takeWhile (< (len `div` 2)))
657 it "drop all" $ transform (A.drop len) (drop len)
658 it "drop none" $ transform (A.drop 0) (drop 0)
659 it "drop some" $ transform (A.drop $ len - 1) (drop $ len - 1)
660 it "drop one" $ transform (A.drop 1) (drop 1)
662 it "dropWhile true" $ transform (A.dropWhile (const True))
663 (dropWhile (const True))
664 it "dropWhile false" $ transform (A.dropWhile (const False))
665 (dropWhile (const False))
666 it "dropWhile < some" $ transform (A.dropWhile (< (len `div` 2)))
667 (dropWhile (< (len `div` 2)))
669 it "scan left" $ transform (A.scan (+) 0 id) (scanl (+) 0)
671 -- Elimination
672 it "foldl" $ elimination (A.foldl (+) 0 id) (foldl (+) 0)
673 it "all" $ elimination (A.all even) (all even)
674 it "any" $ elimination (A.any even) (any even)
675 it "length" $ elimination A.length length
676 it "elem" $ elimination (A.elem (len - 1)) (elem (len - 1))
677 it "elem" $ elimination (A.elem (len + 1)) (elem (len + 1))
678 it "notElem" $ elimination (A.notElem (len - 1)) (notElem (len - 1))
679 it "notElem" $ elimination (A.notElem (len + 1)) (notElem (len + 1))
680 it "sum" $ elimination A.sum sum
681 it "product" $ elimination A.product product
683 if list == []
684 then do
685 it "head empty" $ A.head stream `shouldReturn` Nothing
686 it "last empty" $ A.last stream `shouldReturn` Nothing
687 it "maximum empty" $ A.maximum stream `shouldReturn` Nothing
688 it "minimum empty" $ A.minimum stream `shouldReturn` Nothing
689 else do
690 it "head nonEmpty" $ A.head stream `shouldReturn` Just (head list)
691 it "last nonEmpty" $ A.last stream `shouldReturn` Just (last list)
692 it "maximum nonEmpty" $ A.maximum stream `shouldReturn` Just (maximum list)
693 it "minimum nonEmpty" $ A.minimum stream `shouldReturn` Just (minimum list)
695 where
697 -- XXX run on empty stream as well
698 transform streamOp listOp =
699 (A.toList $ streamOp stream) `shouldReturn` listOp list
701 elimination streamOp listOp = (streamOp stream) `shouldReturn` listOp list