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