@@ -1,16 +1,19 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
45
56module Main (main) where
67
78import Control.Concurrent (threadDelay)
8−import Control.Exception (Exception, try)
9+import Control.Exception (Exception, try, ErrorCall(..), catch, throw)
910import Control.Monad.Catch (throwM, MonadThrow)
1011import Control.Monad.Error.Class (throwError, MonadError)
1112import Control.Monad.Trans.Except (runExceptT, ExceptT)
1213import Data.Foldable (forM_, fold)
1314import Data.List (sort)
15+
16+import Data.IORef
1417import Test.Hspec
1518
1619import Streamly
@@ -88,30 +91,6 @@ main = hspec $ do
8891 (toListParallel ((,) <$> (return 1) <*> (return 2 <> return 3)) >>= return . sort)
8992 `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
9093
91− ---------------------------------------------------------------------------
92− -- Semigroup/Monoidal Composition strict ordering checks
93− ---------------------------------------------------------------------------
94−
95− -- test both (<>) and mappend to make sure we are using correct instance
96− -- for Monoid that is using the right version of semigroup. Instance
97− -- deriving can cause us to pick wrong instances sometimes.
98−
99− describe "WSerial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)
100− describe "WSerial interleaved mappend ordering check" $ interleaveCheck wSerially mappend
101−
102− -- describe "WAsync interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)
103− -- describe "WAsync interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend
104−
105− describe "Async (<>) time order check" $ parallelCheck asyncly (<>)
106− describe "Async mappend time order check" $ parallelCheck asyncly mappend
107−
108− -- XXX this keeps failing intermittently, need to investigate
109− -- describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>)
110− -- describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend
111−
112− describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)
113− describe "Parallel mappend time order check" $ parallelCheck parallely mappend
114−
11594 ---------------------------------------------------------------------------
11695 -- Monoidal Compositions, multiset equality checks
11796 ---------------------------------------------------------------------------
@@ -384,6 +363,50 @@ main = hspec $ do
384363 describe "take on infinite concurrent stream" $ takeInfinite wAsyncly
385364 describe "take on infinite concurrent stream" $ takeInfinite aheadly
386365
366+ ---------------------------------------------------------------------------
367+ -- Folds are strict enough
368+ ---------------------------------------------------------------------------
369+
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)
377+
378+ ---------------------------------------------------------------------------
379+ -- Slower tests are at the end
380+ ---------------------------------------------------------------------------
381+
382+ ---------------------------------------------------------------------------
383+ -- Semigroup/Monoidal Composition strict ordering checks
384+ ---------------------------------------------------------------------------
385+
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.
389+
390+ describe "WSerial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)
391+ describe "WSerial interleaved mappend ordering check" $ interleaveCheck wSerially mappend
392+
393+ -- describe "WAsync interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)
394+ -- describe "WAsync interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend
395+
396+ describe "Async (<>) time order check" $ parallelCheck asyncly (<>)
397+ describe "Async mappend time order check" $ parallelCheck asyncly mappend
398+
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
402+
403+ describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)
404+ describe "Parallel mappend time order check" $ parallelCheck parallely mappend
405+
406+ ---------------------------------------------------------------------------
407+ -- Thread limits
408+ ---------------------------------------------------------------------------
409+
387410 it "asyncly crosses thread limit (2000 threads)" $
388411 runStream (asyncly $ fold $
389412 replicate 2000 $ S.yieldM $ threadDelay 1000000)
@@ -394,6 +417,90 @@ main = hspec $ do
394417 replicate 4000 $ S.yieldM $ threadDelay 1000000)
395418 `shouldReturn` ()
396419
420+
421+checkFoldxStrictness :: IO ()
422+checkFoldxStrictness = 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"
430+
431+checkFoldl'Strictness :: IO ()
432+checkFoldl'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"
440+
441+checkScanxStrictness :: IO ()
442+checkScanxStrictness = 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"
458+
459+checkScanl'Strictness :: IO ()
460+checkScanl'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"
477+
478+foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()
479+foldlM'StrictCheck ref s =
480+ S.foldlM' (\_ _ -> writeIORef ref 1) () s
481+
482+foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO ()
483+foldxMStrictCheck ref s =
484+ S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return s
485+
486+checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()
487+checkFoldMStrictness 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
492+
493+scanlM'StrictCheck :: IORef Int -> SerialT IO Int -> SerialT IO ()
494+scanlM'StrictCheck ref s =
495+ S.scanlM' (\_ _ -> writeIORef ref 1) () s
496+
497+checkScanlMStrictness :: (IORef Int -> SerialT IO Int -> SerialT IO ()) -> IO ()
498+checkScanlMStrictness 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
503+
397504takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
398505takeInfinite t = do
399506 it "take 1" $