git.iko.soy/streamly
on ec08681 help sign in
streamly/test/Main.hs
924 lines 39 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE ScopedTypeVariables #-}
6module Main (main) where
8import Control.Concurrent (threadDelay)
9import Control.Exception (Exception, try, ErrorCall(..), catch, throw)
10import Control.Monad.Catch (throwM, MonadThrow)
11import Control.Monad.Error.Class (throwError, MonadError)
12import Control.Monad.Trans.Except (runExceptT, ExceptT)
13import Data.Foldable (forM_, fold)
14import Data.List (sort)
16import Data.IORef
17import Test.Hspec
19import Streamly
20import Streamly.Prelude ((.:), nil)
21import qualified Streamly.Prelude as S
23singleton :: IsStream t => a -> t m a
24singleton a = a .: nil
26toListSerial :: SerialT IO a -> IO [a]
27toListSerial = S.toList . serially
29toListInterleaved :: WSerialT IO a -> IO [a]
30toListInterleaved = S.toList . wSerially
32toListAsync :: AsyncT IO a -> IO [a]
33toListAsync = S.toList . asyncly
35toListParallel :: WAsyncT IO a -> IO [a]
36toListParallel = S.toList . wAsyncly
38main :: IO ()
39main = hspec $ do
40 describe "Runners" $ do
41 -- XXX move these to property tests
42 -- XXX use an IORef to store and check the side effects
43 it "simple serially" $
44 (runStream . serially) (return (0 :: Int)) `shouldReturn` ()
45 it "simple serially with IO" $
46 (runStream . serially) (S.yieldM $ putStrLn "hello") `shouldReturn` ()
48 describe "Empty" $ do
49 it "Monoid - mempty" $
50 (toListSerial mempty) `shouldReturn` ([] :: [Int])
51 -- it "Alternative - empty" $
52 -- (toListSerial empty) `shouldReturn` ([] :: [Int])
53 -- it "MonadPlus - mzero" $
54 -- (toListSerial mzero) `shouldReturn` ([] :: [Int])
56 ---------------------------------------------------------------------------
57 -- Functor
58 ---------------------------------------------------------------------------
60 describe "Functor (fmap)" $ do
61 -- XXX we should do these through property tests by using a
62 -- construction via list fold construction method.
63 it "fmap on composed (<>)" $
64 (toListSerial $ fmap (+1) (return 1 <> return 2))
65 `shouldReturn` ([2,3] :: [Int])
67 it "fmap on composed (<>)" $
68 ((toListParallel $ fmap (+1) (return 1 <> return 2)) >>= return . sort)
69 `shouldReturn` ([2,3] :: [Int])
71 ---------------------------------------------------------------------------
72 -- Applicative
73 ---------------------------------------------------------------------------
75 describe "Applicative" $ do
76 -- XXX we should do these through property tests by using a
77 -- construction via list fold construction method.
78 it "Apply - serial composed first argument" $
79 (toListSerial $ (,) <$> (return 1 <> return 2) <*> (return 3))
80 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
82 it "Apply - serial composed second argument" $
83 (toListSerial $ (,) <$> (return 1) <*> (return 2 <> return 3))
84 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
86 it "Apply - parallel composed first argument" $
87 (toListParallel ((,) <$> (return 1 <> return 2) <*> (return 3)) >>= return . sort)
88 `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
90 it "Apply - parallel composed second argument" $
91 (toListParallel ((,) <$> (return 1) <*> (return 2 <> return 3)) >>= return . sort)
92 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
94 ---------------------------------------------------------------------------
95 -- Monoidal Compositions, multiset equality checks
96 ---------------------------------------------------------------------------
98 describe "Serial Composition" $ compose serially mempty id
99 describe "Ahead Composition" $ compose aheadly mempty id
100 describe "WSerial Composition" $ compose wSerially mempty sort
101 describe "Async Composition" $ compose asyncly mempty sort
102 describe "WAsync Composition" $ compose wAsyncly mempty sort
103 describe "Parallel Composition" $ compose parallely mempty sort
104 describe "Semigroup Composition for ZipSerial" $ compose zipSerially mempty id
105 describe "Semigroup Composition for ZipAsync" $ compose zipAsyncly mempty id
106 -- XXX need to check alternative compositions as well
108 ---------------------------------------------------------------------------
109 -- TBD Monoidal composition combinations
110 ---------------------------------------------------------------------------
112 -- TBD need more such combinations to be tested.
113 describe "serial <> and serial <>" $ composeAndComposeSimple serially serially (cycle [[1 .. 9]])
114 describe "ahead <> and ahead <>" $ composeAndComposeSimple aheadly aheadly (cycle [[1 .. 9]])
115 describe "ahead <> and serial <>" $ composeAndComposeSimple aheadly serially (cycle [[1 .. 9]])
116 describe "serial <> and ahead <>" $ composeAndComposeSimple serially aheadly (cycle [[1 .. 9]])
118 describe "<> and <=>" $ composeAndComposeSimple
119 serially
120 wSerially
121 ([ [1 .. 9]
122 , [1 .. 9]
123 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
124 , [1, 3, 2, 4, 6, 5, 7, 9, 8]
125 ])
127 describe "<=> and <=>" $ composeAndComposeSimple
128 wSerially
129 wSerially
130 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
131 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
132 , [1, 4, 3, 7, 2, 6, 9, 5, 8]
133 , [1, 7, 4, 9, 3, 8, 6, 2, 5]
134 ])
136 describe "<=> and <>" $ composeAndComposeSimple
137 wSerially
138 serially
139 ([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
140 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
141 , [1, 4, 2, 7, 3, 5, 8, 6, 9]
142 , [1, 7, 4, 8, 2, 9, 5, 3, 6]
143 ])
145 describe "Nested parallel and serial compositions" $ do
146 let t = timed
147 p = wAsyncly
148 s = serially
149 {-
150 -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
151 -- because of parallelism of [8,0] and [8,0].
152 it "Nest <|>, <>, <|> (1)" $
153 let t = timed
154 in toListSerial (
155 ((t 8 <|> t 4) <> (t 2 <|> t 0))
156 <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
157 `shouldReturn` ([4,4,8,8,0,0,2,2])
158 -}
159 it "Nest <|>, <>, <|> (2)" $
160 (S.toList . wAsyncly) (
161 s (p (t 4 <> t 8) <> p (t 1 <> t 2))
162 <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))
163 `shouldReturn` ([4,4,8,8,1,1,2,2])
164 -- FIXME: These two keep failing intermittently on Mac OS X
165 -- Need to examine and fix the tests.
166 {-
167 it "Nest <|>, <=>, <|> (1)" $
168 let t = timed
169 in toListSerial (
170 ((t 8 <|> t 4) <=> (t 2 <|> t 0))
171 <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
172 `shouldReturn` ([4,4,0,0,8,2,9,2])
173 it "Nest <|>, <=>, <|> (2)" $
174 let t = timed
175 in toListSerial (
176 ((t 4 <|> t 8) <=> (t 1 <|> t 2))
177 <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
178 `shouldReturn` ([4,4,1,1,8,2,9,2])
179 -}
180 it "Nest <|>, <|>, <|>" $
181 (S.toList . wAsyncly) (
182 ((t 4 <> t 8) <> (t 0 <> t 2))
183 <> ((t 4 <> t 8) <> (t 0 <> t 2)))
184 `shouldReturn` ([0,0,2,2,4,4,8,8])
186 ---------------------------------------------------------------------------
187 -- Monoidal composition recursion loops
188 ---------------------------------------------------------------------------
190 describe "Serial loops" $ loops serially id reverse
191 describe "Ahead loops" $ loops aheadly id reverse
192 describe "Async parallel loops" $ loops asyncly sort sort
193 describe "WAsync loops" $ loops wAsyncly sort sort
194 describe "parallel loops" $ loops parallely sort sort
196 ---------------------------------------------------------------------------
197 -- Bind and monoidal composition combinations
198 ---------------------------------------------------------------------------
200 describe "Bind and compose Stream 1" $ bindAndComposeSimple serially serially
201 describe "Bind and compose Stream 2" $ bindAndComposeSimple serially wSerially
202 describe "Bind and compose Stream 3" $ bindAndComposeSimple serially asyncly
203 describe "Bind and compose Stream 4" $ bindAndComposeSimple serially wAsyncly
204 describe "Bind and compose Stream 5" $ bindAndComposeSimple serially parallely
205 describe "Bind and compose Stream 6" $ bindAndComposeSimple serially aheadly
207 describe "Bind and compose Ahead Stream 0" $ bindAndComposeSimple aheadly aheadly
208 describe "Bind and compose Ahead Stream 1" $ bindAndComposeSimple aheadly serially
209 describe "Bind and compose Ahead Stream 2" $ bindAndComposeSimple aheadly wSerially
210 describe "Bind and compose Ahead Stream 3" $ bindAndComposeSimple aheadly asyncly
211 describe "Bind and compose Ahead Stream 4" $ bindAndComposeSimple aheadly wAsyncly
212 describe "Bind and compose Ahead Stream 5" $ bindAndComposeSimple aheadly parallely
214 describe "Bind and compose Costream 1" $ bindAndComposeSimple wSerially serially
215 describe "Bind and compose Costream 2" $ bindAndComposeSimple wSerially wSerially
216 describe "Bind and compose Costream 3" $ bindAndComposeSimple wSerially asyncly
217 describe "Bind and compose Costream 4" $ bindAndComposeSimple wSerially wAsyncly
218 describe "Bind and compose Costream 5" $ bindAndComposeSimple wSerially parallely
219 describe "Bind and compose Costream 6" $ bindAndComposeSimple wSerially aheadly
221 describe "Bind and compose Async 1" $ bindAndComposeSimple asyncly serially
222 describe "Bind and compose Async 2" $ bindAndComposeSimple asyncly wSerially
223 describe "Bind and compose Async 3" $ bindAndComposeSimple asyncly asyncly
224 describe "Bind and compose Async 4" $ bindAndComposeSimple asyncly wAsyncly
225 describe "Bind and compose Async 5" $ bindAndComposeSimple asyncly parallely
226 describe "Bind and compose Async 6" $ bindAndComposeSimple asyncly aheadly
228 describe "Bind and compose WAsync 1" $ bindAndComposeSimple wAsyncly serially
229 describe "Bind and compose WAsync 2" $ bindAndComposeSimple wAsyncly wSerially
230 describe "Bind and compose WAsync 3" $ bindAndComposeSimple wAsyncly asyncly
231 describe "Bind and compose WAsync 4" $ bindAndComposeSimple wAsyncly wAsyncly
232 describe "Bind and compose WAsync 5" $ bindAndComposeSimple wAsyncly parallely
233 describe "Bind and compose WAsync 6" $ bindAndComposeSimple wAsyncly aheadly
235 describe "Bind and compose Parallel 1" $ bindAndComposeSimple parallely serially
236 describe "Bind and compose Parallel 2" $ bindAndComposeSimple parallely wSerially
237 describe "Bind and compose Parallel 3" $ bindAndComposeSimple parallely asyncly
238 describe "Bind and compose Parallel 4" $ bindAndComposeSimple parallely wAsyncly
239 describe "Bind and compose Parallel 5" $ bindAndComposeSimple parallely parallely
240 describe "Bind and compose Parallel 6" $ bindAndComposeSimple parallely aheadly
242 let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int
243 fldr = foldr (<>) nil
244 fldl = foldl (<>) nil
246 forM_ [fldr, fldl] $ \k ->
247 describe "Bind and compose" $ bindAndComposeHierarchy serially serially k
248 forM_ [fldr, fldl] $ \k ->
249 describe "Bind and compose" $ bindAndComposeHierarchy serially wSerially k
250 forM_ [fldr, fldl] $ \k ->
251 describe "Bind and compose" $ bindAndComposeHierarchy serially asyncly k
252 forM_ [fldr, fldl] $ \k ->
253 describe "Bind and compose" $ bindAndComposeHierarchy serially wAsyncly k
254 forM_ [fldr, fldl] $ \k ->
255 describe "Bind and compose" $ bindAndComposeHierarchy serially parallely k
256 forM_ [fldr, fldl] $ \k ->
257 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy serially aheadly k
259 forM_ [fldr, fldl] $ \k ->
260 describe "Bind and compose aheadly serially" $ bindAndComposeHierarchy aheadly serially k
261 forM_ [fldr, fldl] $ \k ->
262 describe "Bind and compose aheadly wSerially" $ bindAndComposeHierarchy aheadly wSerially k
263 forM_ [fldr, fldl] $ \k ->
264 describe "Bind and compose aheadly asyncly" $ bindAndComposeHierarchy aheadly asyncly k
265 forM_ [fldr, fldl] $ \k ->
266 describe "Bind and compose aheadly wAsyncly" $ bindAndComposeHierarchy aheadly wAsyncly k
267 forM_ [fldr, fldl] $ \k ->
268 describe "Bind and compose aheadly parallely" $ bindAndComposeHierarchy aheadly parallely k
269 forM_ [fldr, fldl] $ \k ->
270 describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy aheadly aheadly k
272 forM_ [fldr, fldl] $ \k ->
273 describe "Bind and compose" $ bindAndComposeHierarchy wSerially serially k
274 forM_ [fldr, fldl] $ \k ->
275 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wSerially k
276 forM_ [fldr, fldl] $ \k ->
277 describe "Bind and compose" $ bindAndComposeHierarchy wSerially asyncly k
278 forM_ [fldr, fldl] $ \k ->
279 describe "Bind and compose" $ bindAndComposeHierarchy wSerially wAsyncly k
280 forM_ [fldr, fldl] $ \k ->
281 describe "Bind and compose" $ bindAndComposeHierarchy wSerially parallely k
282 forM_ [fldr, fldl] $ \k ->
283 describe "Bind and compose wserially aheadly" $ bindAndComposeHierarchy wSerially aheadly k
285 forM_ [fldr, fldl] $ \k ->
286 describe "Bind and compose" $ bindAndComposeHierarchy asyncly serially k
287 forM_ [fldr, fldl] $ \k ->
288 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wSerially k
289 forM_ [fldr, fldl] $ \k ->
290 describe "Bind and compose" $ bindAndComposeHierarchy asyncly asyncly k
291 forM_ [fldr, fldl] $ \k ->
292 describe "Bind and compose" $ bindAndComposeHierarchy asyncly wAsyncly k
293 forM_ [fldr, fldl] $ \k ->
294 describe "Bind and compose" $ bindAndComposeHierarchy asyncly parallely k
295 forM_ [fldr, fldl] $ \k ->
296 describe "Bind and compose asyncly aheadly" $ bindAndComposeHierarchy asyncly aheadly k
298 forM_ [fldr, fldl] $ \k ->
299 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly serially k
300 forM_ [fldr, fldl] $ \k ->
301 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wSerially k
302 forM_ [fldr, fldl] $ \k ->
303 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly asyncly k
304 forM_ [fldr, fldl] $ \k ->
305 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wAsyncly k
306 forM_ [fldr, fldl] $ \k ->
307 describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly parallely k
308 forM_ [fldr, fldl] $ \k ->
309 describe "Bind and compose wAsyncly aheadly" $ bindAndComposeHierarchy wAsyncly aheadly k
311 forM_ [fldr, fldl] $ \k ->
312 describe "Bind and compose" $ bindAndComposeHierarchy parallely serially k
313 forM_ [fldr, fldl] $ \k ->
314 describe "Bind and compose" $ bindAndComposeHierarchy parallely wSerially k
315 forM_ [fldr, fldl] $ \k ->
316 describe "Bind and compose" $ bindAndComposeHierarchy parallely asyncly k
317 forM_ [fldr, fldl] $ \k ->
318 describe "Bind and compose" $ bindAndComposeHierarchy parallely wAsyncly k
319 forM_ [fldr, fldl] $ \k ->
320 describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k
321 forM_ [fldr, fldl] $ \k ->
322 describe "Bind and compose parallely aheadly" $ bindAndComposeHierarchy parallely aheadly k
324 -- Nest two lists using different styles of product compositions
325 it "Nests two streams using monadic serial composition" nestTwoSerial
326 it "Nests two streams using monadic ahead composition" nestTwoAhead
327 it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
328 it "Nests two streams using monadic Async composition" nestTwoAsync
329 it "Nests two streams using monadic WAsync composition" nestTwoWAsync
330 it "Nests two streams using monadic parallel composition" nestTwoParallel
332 it "Nests two streams using applicative serial composition" nestTwoSerialApp
333 it "Nests two streams using applicative ahead composition" nestTwoAheadApp
334 it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
335 it "Nests two streams using applicative Async composition" nestTwoAsyncApp
336 it "Nests two streams using applicative WAsync composition" nestTwoWAsyncApp
337 it "Nests two streams using applicative parallel composition" nestTwoParallelApp
339 ---------------------------------------------------------------------------
340 -- TBD Bind and Bind combinations
341 ---------------------------------------------------------------------------
343 -- TBD combine all binds and all compose in one example
344 describe "Miscellaneous combined examples" mixedOps
345 describe "Miscellaneous combined examples aheadly" mixedOpsAheadly
346 describe "Simple MonadError and MonadThrow" simpleMonadError
348 {-
349 describe "Composed MonadError serially" $ composeWithMonadError serially
350 describe "Composed MonadError wSerially" $ composeWithMonadError wSerially
351 describe "Composed MonadError asyncly" $ composeWithMonadError asyncly
352 describe "Composed MonadError wAsyncly" $ composeWithMonadError wAsyncly
353 -}
355 describe "Composed MonadThrow serially" $ composeWithMonadThrow serially
356 describe "Composed MonadThrow wSerially" $ composeWithMonadThrow wSerially
357 describe "Composed MonadThrow asyncly" $ composeWithMonadThrow asyncly
358 describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow wAsyncly
359 describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely
360 describe "Composed MonadThrow aheadly" $ composeWithMonadThrow aheadly
362 describe "take on infinite concurrent stream" $ takeInfinite asyncly
363 describe "take on infinite concurrent stream" $ takeInfinite wAsyncly
364 describe "take on infinite concurrent stream" $ takeInfinite aheadly
366 ---------------------------------------------------------------------------
367 -- Folds are strict enough
368 ---------------------------------------------------------------------------
370 it "foldx is strict enough" checkFoldxStrictness
371 it "foldl' is strict enough" checkFoldl'Strictness
372 it "scanx is strict enough" checkScanxStrictness
373 it "scanl' is strict enough" checkScanl'Strictness
374 it "foldxM is strict enough" (checkFoldMStrictness foldxMStrictCheck)
375 it "foldlM' is strict enough" (checkFoldMStrictness foldlM'StrictCheck)
376 it "scanlM' is strict enough" (checkScanlMStrictness scanlM'StrictCheck)
378 ---------------------------------------------------------------------------
379 -- Slower tests are at the end
380 ---------------------------------------------------------------------------
382 ---------------------------------------------------------------------------
383 -- Semigroup/Monoidal Composition strict ordering checks
384 ---------------------------------------------------------------------------
386 -- test both (<>) and mappend to make sure we are using correct instance
387 -- for Monoid that is using the right version of semigroup. Instance
388 -- deriving can cause us to pick wrong instances sometimes.
390 describe "WSerial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)
391 describe "WSerial interleaved mappend ordering check" $ interleaveCheck wSerially mappend
393 -- describe "WAsync interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)
394 -- describe "WAsync interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend
396 describe "Async (<>) time order check" $ parallelCheck asyncly (<>)
397 describe "Async mappend time order check" $ parallelCheck asyncly mappend
399 -- XXX this keeps failing intermittently, need to investigate
400 -- describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>)
401 -- describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend
403 describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)
404 describe "Parallel mappend time order check" $ parallelCheck parallely mappend
406 ---------------------------------------------------------------------------
407 -- Thread limits
408 ---------------------------------------------------------------------------
410 it "asyncly crosses thread limit (2000 threads)" $
411 runStream (asyncly $ fold $
412 replicate 2000 $ S.yieldM $ threadDelay 1000000)
413 `shouldReturn` ()
415 it "aheadly crosses thread limit (4000 threads)" $
416 runStream (aheadly $ fold $
417 replicate 4000 $ S.yieldM $ threadDelay 1000000)
418 `shouldReturn` ()
421checkFoldxStrictness :: IO ()
422checkFoldxStrictness = do
423 let s = return (1 :: Int) `S.consM` error "failure"
424 catch (S.foldx (\_ a -> if a == 1 then error "success" else "done")
425 "begin" id s)
426 (\e -> case e of
427 ErrorCall err -> return err
428 _ -> throw e)
429 `shouldReturn` "success"
431checkFoldl'Strictness :: IO ()
432checkFoldl'Strictness = do
433 let s = return (1 :: Int) `S.consM` error "failure"
434 catch (S.foldl' (\_ a -> if a == 1 then error "success" else "done")
435 "begin" s)
436 (\e -> case e of
437 ErrorCall err -> return err
438 _ -> throw e)
439 `shouldReturn` "success"
441checkScanxStrictness :: IO ()
442checkScanxStrictness = do
443 let s = return (1 :: Int) `S.consM` error "failure"
444 catch
445 (runStream (
446 S.scanx (\_ a ->
447 if a == 1
448 then error "success"
449 else "done")
450 "begin" id s
451 )
452 >> return "finished"
453 )
454 (\e -> case e of
455 ErrorCall err -> return err
456 _ -> throw e)
457 `shouldReturn` "success"
459checkScanl'Strictness :: IO ()
460checkScanl'Strictness = do
461 let s = return (1 :: Int) `S.consM` error "failure"
462 catch
463 (runStream
464 (S.scanl'
465 (\_ a ->
466 if a == 1
467 then error "success"
468 else "done")
469 "begin"
470 s)
471 >> return "finished"
472 )
473 (\e -> case e of
474 ErrorCall err -> return err
475 _ -> throw e)
476 `shouldReturn` "success"
478foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()
479foldlM'StrictCheck ref s =
480 S.foldlM' (\_ _ -> writeIORef ref 1) () s
482foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO ()
483foldxMStrictCheck ref s =
484 S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return s
486checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()
487checkFoldMStrictness f = do
488 ref <- newIORef 0
489 let s = return 1 `S.consM` error "x"
490 catch (f ref s) (\(_ :: ErrorCall) -> return ())
491 readIORef ref `shouldReturn` 1
493scanlM'StrictCheck :: IORef Int -> SerialT IO Int -> SerialT IO ()
494scanlM'StrictCheck ref s =
495 S.scanlM' (\_ _ -> writeIORef ref 1) () s
497checkScanlMStrictness :: (IORef Int -> SerialT IO Int -> SerialT IO ()) -> IO ()
498checkScanlMStrictness f = do
499 ref <- newIORef 0
500 let s = return 1 `S.consM` error "x"
501 catch (runStream $ f ref s) (\(_ :: ErrorCall) -> return ())
502 readIORef ref `shouldReturn` 1
504takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
505takeInfinite t = do
506 it "take 1" $
507 (runStream $ t $
508 S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))
509 `shouldReturn` ()
511-- XXX need to test that we have promptly cleaned up everything after the error
512-- XXX We can also check the output that we are expected to get before the
513-- error occurs.
515data ExampleException = ExampleException String deriving (Eq, Show)
517instance Exception ExampleException
519simpleMonadError :: Spec
520simpleMonadError = do
521{-
522 it "simple runExceptT" $ do
523 (runExceptT $ runStream $ return ())
524 `shouldReturn` (Right () :: Either String ())
525 it "simple runExceptT with error" $ do
526 (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"
527 -}
528 it "simple try" $ do
529 (try $ runStream $ return ())
530 `shouldReturn` (Right () :: Either ExampleException ())
531 it "simple try with throw error" $ do
532 (try $ runStream $ throwM $ ExampleException "E")
533 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
535composeWithMonadThrow
536 :: ( IsStream t
537 , Semigroup (t IO Int)
538 , MonadThrow (t IO)
539 )
540 => (t IO Int -> SerialT IO Int) -> Spec
541composeWithMonadThrow t = do
542 it "Compose throwM, nil" $
543 (try $ tl (throwM (ExampleException "E") <> S.nil))
544 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
545 it "Compose nil, throwM" $
546 (try $ tl (S.nil <> throwM (ExampleException "E")))
547 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
548 oneLevelNestedSum "serially" serially
549 oneLevelNestedSum "wSerially" wSerially
550 oneLevelNestedSum "asyncly" asyncly
551 oneLevelNestedSum "wAsyncly" wAsyncly
552 -- XXX add two level nesting
554 oneLevelNestedProduct "serially" serially
555 oneLevelNestedProduct "wSerially" wSerially
556 oneLevelNestedProduct "asyncly" asyncly
557 oneLevelNestedProduct "wAsyncly" wAsyncly
559 where
560 tl = S.toList . t
561 oneLevelNestedSum desc t1 =
562 it ("One level nested sum " ++ desc) $ do
563 let nested = (S.fromFoldable [1..10] <> throwM (ExampleException "E")
564 <> S.fromFoldable [1..10])
565 (try $ tl (S.nil <> t1 nested <> S.fromFoldable [1..10]))
566 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
568 oneLevelNestedProduct desc t1 =
569 it ("One level nested product" ++ desc) $ do
570 let s1 = t $ foldMapWith (<>) return [1..4]
571 s2 = t1 $ foldMapWith (<>) return [5..8]
572 try $ tl (do
573 x <- adapt s1
574 y <- s2
575 if (x + y > 10)
576 then throwM (ExampleException "E")
577 else return (x + y)
578 )
579 `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])
581_composeWithMonadError
582 :: ( IsStream t
583 , Semigroup (t (ExceptT String IO) Int)
584 , MonadError String (t (ExceptT String IO))
585 )
586 => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec
587_composeWithMonadError t = do
588 let tl = S.toList . t
589 it "Compose throwError, nil" $
590 (runExceptT $ tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"
591 it "Compose nil, error" $
592 (runExceptT $ tl (S.nil <> throwError "E")) `shouldReturn` Left "E"
594nestTwoSerial :: Expectation
595nestTwoSerial =
596 let s1 = foldMapWith (<>) return [1..4]
597 s2 = foldMapWith (<>) return [5..8]
598 in toListSerial (do
599 x <- s1
600 y <- s2
601 return (x + y)
602 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
604nestTwoAhead :: Expectation
605nestTwoAhead =
606 let s1 = foldMapWith (<>) return [1..4]
607 s2 = foldMapWith (<>) return [5..8]
608 in (S.toList . aheadly) (do
609 x <- s1
610 y <- s2
611 return (x + y)
612 ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
614nestTwoSerialApp :: Expectation
615nestTwoSerialApp =
616 let s1 = foldMapWith (<>) return [1..4]
617 s2 = foldMapWith (<>) return [5..8]
618 in toListSerial ((+) <$> s1 <*> s2)
619 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
621nestTwoAheadApp :: Expectation
622nestTwoAheadApp =
623 let s1 = foldMapWith (<>) return [1..4]
624 s2 = foldMapWith (<>) return [5..8]
625 in (S.toList . aheadly) ((+) <$> s1 <*> s2)
626 `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
628nestTwoInterleaved :: Expectation
629nestTwoInterleaved =
630 let s1 = foldMapWith (<>) return [1..4]
631 s2 = foldMapWith (<>) return [5..8]
632 in toListInterleaved (do
633 x <- s1
634 y <- s2
635 return (x + y)
636 ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
638nestTwoInterleavedApp :: Expectation
639nestTwoInterleavedApp =
640 let s1 = foldMapWith (<>) return [1..4]
641 s2 = foldMapWith (<>) return [5..8]
642 in toListInterleaved ((+) <$> s1 <*> s2)
643 `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
645nestTwoAsync :: Expectation
646nestTwoAsync =
647 let s1 = foldMapWith (<>) return [1..4]
648 s2 = foldMapWith (<>) return [5..8]
649 in (toListAsync (do
650 x <- s1
651 y <- s2
652 return (x + y)
653 ) >>= return . sort)
654 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
656nestTwoAsyncApp :: Expectation
657nestTwoAsyncApp =
658 let s1 = foldMapWith (<>) return [1..4]
659 s2 = foldMapWith (<>) return [5..8]
660 in (toListAsync ((+) <$> s1 <*> s2) >>= return . sort)
661 `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
663nestTwoWAsync :: Expectation
664nestTwoWAsync =
665 let s1 = foldMapWith (<>) return [1..4]
666 s2 = foldMapWith (<>) return [5..8]
667 in ((S.toList . wAsyncly) (do
668 x <- s1
669 y <- s2
670 return (x + y)
671 ) >>= return . sort)
672 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
674nestTwoParallel :: Expectation
675nestTwoParallel =
676 let s1 = foldMapWith (<>) return [1..4]
677 s2 = foldMapWith (<>) return [5..8]
678 in ((S.toList . parallely) (do
679 x <- s1
680 y <- s2
681 return (x + y)
682 ) >>= return . sort)
683 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
685nestTwoWAsyncApp :: Expectation
686nestTwoWAsyncApp =
687 let s1 = foldMapWith (<>) return [1..4]
688 s2 = foldMapWith (<>) return [5..8]
689 in ((S.toList . wAsyncly) ((+) <$> s1 <*> s2) >>= return . sort)
690 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
692nestTwoParallelApp :: Expectation
693nestTwoParallelApp =
694 let s1 = foldMapWith (<>) return [1..4]
695 s2 = foldMapWith (<>) return [5..8]
696 in ((S.toList . parallely) ((+) <$> s1 <*> s2) >>= return . sort)
697 `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
699timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int
700timed x = S.yieldM (threadDelay (x * 100000)) >> return x
702interleaveCheck :: IsStream t
703 => (t IO Int -> SerialT IO Int)
704 -> (t IO Int -> t IO Int -> t IO Int)
705 -> Spec
706interleaveCheck t f =
707 it "Interleave four" $
708 (S.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))
709 `shouldReturn` ([0, 100, 1, 101])
711parallelCheck :: (IsStream t, Monad (t IO))
712 => (t IO Int -> SerialT IO Int)
713 -> (t IO Int -> t IO Int -> t IO Int)
714 -> Spec
715parallelCheck t f = do
716 it "Parallel ordering left associated" $
717 (S.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)
718 `shouldReturn` ([1..4])
720 it "Parallel ordering right associated" $
721 (S.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
722 `shouldReturn` ([1..4])
724 where event n = (S.yieldM $ threadDelay (n * 200000)) >> (return n)
726compose :: (IsStream t, Semigroup (t IO Int))
727 => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec
728compose t z srt = do
729 -- XXX these should get covered by the property tests
730 it "Compose mempty, mempty" $
731 (tl (z <> z)) `shouldReturn` ([] :: [Int])
732 it "Compose empty at the beginning" $
733 (tl $ (z <> singleton 1)) `shouldReturn` [1]
734 it "Compose empty at the end" $
735 (tl $ (singleton 1 <> z)) `shouldReturn` [1]
736 it "Compose two" $
737 (tl (singleton 0 <> singleton 1) >>= return . srt)
738 `shouldReturn` [0, 1]
739 it "Compose many" $
740 ((tl $ forEachWith (<>) [1..100] singleton) >>= return . srt)
741 `shouldReturn` [1..100]
743 -- These are not covered by the property tests
744 it "Compose three - empty in the middle" $
745 ((tl $ (singleton 0 <> z <> singleton 1)) >>= return . srt)
746 `shouldReturn` [0, 1]
747 it "Compose left associated" $
748 ((tl $ (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3))
749 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
750 it "Compose right associated" $
751 ((tl $ (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3))))
752 >>= return . srt) `shouldReturn` [0, 1, 2, 3]
753 it "Compose hierarchical (multiple levels)" $
754 ((tl $ (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))
755 <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))
756 ) >>= return . srt) `shouldReturn` [0..7]
757 where tl = S.toList . t
759composeAndComposeSimple
760 :: ( IsStream t1, Semigroup (t1 IO Int)
761 , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)
762#if __GLASGOW_HASKELL__ < 804
763 , Semigroup (t2 IO Int)
764#endif
765 )
766 => (t1 IO Int -> SerialT IO Int)
767 -> (t2 IO Int -> t2 IO Int)
768 -> [[Int]] -> Spec
769composeAndComposeSimple t1 t2 answer = do
770 let rfold = adapt . t2 . foldMapWith (<>) return
771 it "Compose right associated outer expr, right folded inner" $
772 ((S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9])))
773 `shouldReturn` (answer !! 0)
775 it "Compose left associated outer expr, right folded inner" $
776 ((S.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9]))
777 `shouldReturn` (answer !! 1)
779 let lfold xs = adapt $ t2 $ foldl (<>) mempty $ map return xs
780 it "Compose right associated outer expr, left folded inner" $
781 ((S.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9])))
782 `shouldReturn` (answer !! 2)
784 it "Compose left associated outer expr, left folded inner" $
785 ((S.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9]))
786 `shouldReturn` (answer !! 3)
788loops
789 :: (IsStream t, Semigroup (t IO Int), Monad (t IO))
790 => (t IO Int -> t IO Int)
791 -> ([Int] -> [Int])
792 -> ([Int] -> [Int])
793 -> Spec
794loops t tsrt hsrt = do
795 it "Tail recursive loop" $ ((S.toList . adapt) (loopTail 0) >>= return . tsrt)
796 `shouldReturn` [0..3]
798 it "Head recursive loop" $ ((S.toList . adapt) (loopHead 0) >>= return . hsrt)
799 `shouldReturn` [0..3]
801 where
802 loopHead x = do
803 -- this print line is important for the test (causes a bind)
804 S.yieldM $ putStrLn "LoopHead..."
805 t $ (if x < 3 then loopHead (x + 1) else nil) <> return x
807 loopTail x = do
808 -- this print line is important for the test (causes a bind)
809 S.yieldM $ putStrLn "LoopTail..."
810 t $ return x <> (if x < 3 then loopTail (x + 1) else nil)
812bindAndComposeSimple
813 :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))
814 => (t1 IO Int -> SerialT IO Int)
815 -> (t2 IO Int -> t2 IO Int)
816 -> Spec
817bindAndComposeSimple t1 t2 = do
818 -- XXX need a bind in the body of forEachWith instead of a simple return
819 it "Compose many (right fold) with bind" $
820 ((S.toList . t1) (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return)
821 >>= return . sort) `shouldReturn` [1..10]
823 it "Compose many (left fold) with bind" $
824 let forL xs k = foldl (<>) nil $ map k xs
825 in ((S.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return)
826 >>= return . sort) `shouldReturn` [1..10]
828bindAndComposeHierarchy
829 :: ( IsStream t1, Monad (t1 IO)
830 , IsStream t2, Monad (t2 IO))
831 => (t1 IO Int -> SerialT IO Int)
832 -> (t2 IO Int -> t2 IO Int)
833 -> ([t2 IO Int] -> t2 IO Int)
834 -> Spec
835bindAndComposeHierarchy t1 t2 g = do
836 it "Bind and compose nested" $
837 ((S.toList . t1) bindComposeNested >>= return . sort)
838 `shouldReturn` (sort (
839 [12, 18]
840 ++ replicate 3 13
841 ++ replicate 3 17
842 ++ replicate 6 14
843 ++ replicate 6 16
844 ++ replicate 7 15) :: [Int])
846 where
848 -- bindComposeNested :: WAsyncT IO Int
849 bindComposeNested =
850 let c1 = tripleCompose (return 1) (return 2) (return 3)
851 c2 = tripleCompose (return 4) (return 5) (return 6)
852 c3 = tripleCompose (return 7) (return 8) (return 9)
853 b = tripleBind c1 c2 c3
854-- it seems to be causing a huge space leak in hspec so disabling this for now
855-- c = tripleCompose b b b
856-- m = tripleBind c c c
857-- in m
858 in b
860 tripleCompose a b c = adapt . t2 $ g [a, b, c]
861 tripleBind mx my mz =
862 mx >>= \x -> my
863 >>= \y -> mz
864 >>= \z -> return (x + y + z)
866mixedOps :: Spec
867mixedOps = do
868 it "Compose many ops" $
869 (toListSerial composeMixed >>= return . sort)
870 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
871 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
872 ] :: [Int])
873 where
875 composeMixed :: SerialT IO Int
876 composeMixed = do
877 S.yieldM $ return ()
878 S.yieldM $ putStr ""
879 x <- return 1
880 y <- return 2
881 z <- do
882 x1 <- wAsyncly $ return 1 <> return 2
883 S.yieldM $ return ()
884 S.yieldM $ putStr ""
885 y1 <- asyncly $ return 1 <> return 2
886 z1 <- do
887 x11 <- return 1 <> return 2
888 y11 <- asyncly $ return 1 <> return 2
889 z11 <- wSerially $ return 1 <> return 2
890 S.yieldM $ return ()
891 S.yieldM $ putStr ""
892 return (x11 + y11 + z11)
893 return (x1 + y1 + z1)
894 return (x + y + z)
896mixedOpsAheadly :: Spec
897mixedOpsAheadly = do
898 it "Compose many ops" $
899 (toListSerial composeMixed >>= return . sort)
900 `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
901 ,11,11,11,11,11,11,11,11,12,12,12,12,12,13
902 ] :: [Int])
903 where
905 composeMixed :: SerialT IO Int
906 composeMixed = do
907 S.yieldM $ return ()
908 S.yieldM $ putStr ""
909 x <- return 1
910 y <- return 2
911 z <- do
912 x1 <- wAsyncly $ return 1 <> return 2
913 S.yieldM $ return ()
914 S.yieldM $ putStr ""
915 y1 <- aheadly $ return 1 <> return 2
916 z1 <- do
917 x11 <- return 1 <> return 2
918 y11 <- aheadly $ return 1 <> return 2
919 z11 <- parallely $ return 1 <> return 2
920 S.yieldM $ return ()
921 S.yieldM $ putStr ""
922 return (x11 + y11 + z11)
923 return (x1 + y1 + z1)
924 return (x + y + z)