streamly-0.1.2: test/Main.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Main (main) where
import Control.Concurrent (threadDelay)
import Control.Monad (replicateM)
import Data.Foldable (forM_)
import Data.List (sort)
import Data.Maybe (fromJust)
import Test.Hspec
import Streamly
import qualified Streamly.Prelude as A
toListSerial :: StreamT IO a -> IO [a]
toListSerial = A.toList . serially
toListInterleaved :: InterleavedT IO a -> IO [a]
toListInterleaved = A.toList . interleaving
toListAsync :: AsyncT IO a -> IO [a]
toListAsync = A.toList . asyncly
toListParallel :: Ord a => ParallelT IO a -> IO [a]
toListParallel = fmap sort . A.toList . parallely
main :: IO ()
main = hspec $ do
describe "Runners" $ do
it "simple serially" $
(runStreaming . serially) (return (0 :: Int)) `shouldReturn` ()
it "simple serially with IO" $
(runStreaming . serially) (liftIO $ putStrLn "hello") `shouldReturn` ()
it "Captures a return value using toList" $
toListSerial (return 0) `shouldReturn` ([0] :: [Int])
describe "Empty" $ do
it "Monoid - mempty" $
(toListSerial mempty) `shouldReturn` ([] :: [Int])
it "Alternative - empty" $
(toListSerial empty) `shouldReturn` ([] :: [Int])
it "MonadPlus - mzero" $
(toListSerial mzero) `shouldReturn` ([] :: [Int])
---------------------------------------------------------------------------
-- Functor
---------------------------------------------------------------------------
describe "Functor (fmap)" $ do
it "Simple fmap" $
(toListSerial $ fmap (+1) (return 1)) `shouldReturn` ([2] :: [Int])
it "fmap on composed (<>)" $
(toListSerial $ fmap (+1) (return 1 <> return 2))
`shouldReturn` ([2,3] :: [Int])
it "fmap on composed (<|>)" $
(toListSerial $ fmap (+1) (return 1 <|> return 2))
`shouldReturn` ([2,3] :: [Int])
---------------------------------------------------------------------------
-- Applicative
---------------------------------------------------------------------------
describe "Applicative" $ do
it "Simple apply" $
(toListSerial $ (,) <$> (return 1) <*> (return 2))
`shouldReturn` ([(1,2)] :: [(Int, Int)])
it "Apply - serial composed first argument" $
(toListSerial $ (,) <$> (return 1 <> return 2) <*> (return 3))
`shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
it "Apply - serial composed second argument" $
(toListSerial $ (,) <$> (return 1) <*> (return 2 <> return 3))
`shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
it "Apply - parallel composed first argument" $
(toListSerial $ (,) <$> (return 1 <|> return 2) <*> (return 3))
`shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])
it "Apply - parallel composed second argument" $
(toListSerial $ (,) <$> (return 1) <*> (return 2 <|> return 3))
`shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])
---------------------------------------------------------------------------
-- Binds
---------------------------------------------------------------------------
describe "Bind then" thenBind
describe "Pure bind serial" $ pureBind toListSerial
describe "Pure bind serial interleaved" $ pureBind toListInterleaved
describe "Pure bind parallel DFS" $ pureBind toListAsync
describe "Pure bind parallel BFS" $ pureBind toListParallel
describe "Bind (>>=) with empty" $ bindEmpty toListSerial
describe "Bind (>->) with empty" $ bindEmpty toListInterleaved
describe "Bind (>|>) with empty" $ bindEmpty toListAsync
describe "Bind (>>|) with empty" $ bindEmpty toListParallel
---------------------------------------------------------------------------
-- Monoidal Compositions
---------------------------------------------------------------------------
describe "Serial Composition (<>)" $ compose (<>) id
describe "Serial Composition (mappend)" $ compose mappend id
describe "Interleaved Composition (<>)" $ compose (<=>) sort
describe "Left biased parallel Composition (<|)" $ compose (<|) sort
describe "Fair parallel Composition (<|>)" $ compose (<|>) sort
describe "Fair parallel Composition (mplus)" $ compose mplus sort
---------------------------------------------------------------------------
-- Monoidal Composition ordering checks
---------------------------------------------------------------------------
describe "Serial interleaved ordering check (<=>)" $ interleaveCheck (<=>)
describe "Parallel interleaved ordering check (<|>)" $ interleaveCheck (<|>)
describe "Left biased parallel time order check" $ parallelCheck (<|)
describe "Fair parallel time order check" $ parallelCheck (<|>)
---------------------------------------------------------------------------
-- TBD Monoidal composition combinations
---------------------------------------------------------------------------
-- TBD need more such combinations to be tested.
describe "<> and <>" $ composeAndComposeSimple (<>) (<>) (cycle [[1 .. 9]])
describe "<> and <=>" $ composeAndComposeSimple
(<>)
(<=>)
([ [1 .. 9]
, [1 .. 9]
, [1, 3, 2, 4, 6, 5, 7, 9, 8]
, [1, 3, 2, 4, 6, 5, 7, 9, 8]
])
describe "<=> and <=>" $ composeAndComposeSimple
(<=>)
(<=>)
([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
, [1, 7, 4, 8, 2, 9, 5, 3, 6]
, [1, 4, 3, 7, 2, 6, 9, 5, 8]
, [1, 7, 4, 9, 3, 8, 6, 2, 5]
])
describe "<=> and <>" $ composeAndComposeSimple
(<=>)
(<>)
([ [1, 4, 2, 7, 3, 5, 8, 6, 9]
, [1, 7, 4, 8, 2, 9, 5, 3, 6]
, [1, 4, 2, 7, 3, 5, 8, 6, 9]
, [1, 7, 4, 8, 2, 9, 5, 3, 6]
])
describe "Nested parallel and serial compositions" $ do
{-
-- This is not correct, the result can also be [4,4,8,0,8,0,2,2]
-- because of parallelism of [8,0] and [8,0].
it "Nest <|>, <>, <|> (1)" $
let t = timed
in toListSerial (
((t 8 <|> t 4) <> (t 2 <|> t 0))
<|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))
`shouldReturn` ([4,4,8,8,0,0,2,2])
-}
it "Nest <|>, <>, <|> (2)" $
let t = timed
in toListSerial (
((t 4 <|> t 8) <> (t 1 <|> t 2))
<|> ((t 4 <|> t 8) <> (t 1 <|> t 2)))
`shouldReturn` ([4,4,8,8,1,1,2,2])
-- FIXME: These two keep failing intermittently on Mac OS X
-- Need to examine and fix the tests.
{-
it "Nest <|>, <=>, <|> (1)" $
let t = timed
in toListSerial (
((t 8 <|> t 4) <=> (t 2 <|> t 0))
<|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))
`shouldReturn` ([4,4,0,0,8,2,9,2])
it "Nest <|>, <=>, <|> (2)" $
let t = timed
in toListSerial (
((t 4 <|> t 8) <=> (t 1 <|> t 2))
<|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))
`shouldReturn` ([4,4,1,1,8,2,9,2])
-}
it "Nest <|>, <|>, <|>" $
let t = timed
in toListSerial (
((t 4 <|> t 8) <|> (t 0 <|> t 2))
<|> ((t 4 <|> t 8) <|> (t 0 <|> t 2)))
`shouldReturn` ([0,0,2,2,4,4,8,8])
---------------------------------------------------------------------------
-- Monoidal composition recursion loops
---------------------------------------------------------------------------
describe "Serial loops (<>)" $ loops (<>) id reverse
describe "Left biased parallel loops (<|)" $ loops (<|) sort sort
describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort
---------------------------------------------------------------------------
-- Bind and monoidal composition combinations
---------------------------------------------------------------------------
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
describe "Bind and compose" $ bindAndComposeSimple toListSerial g
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
describe "Bind and compose" $ bindAndComposeSimple toListInterleaved g
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
describe "Bind and compose" $ bindAndComposeSimple toListAsync g
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
describe "Bind and compose" $ bindAndComposeSimple toListParallel g
let fldr f = foldr f empty
fldl f = foldl f empty
in do
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
forM_ [fldr, fldl] $ \k ->
describe "Bind and compose" $
bindAndComposeHierarchy toListSerial (k g)
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
forM_ [fldr, fldl] $ \k ->
describe "Bind and compose" $
bindAndComposeHierarchy toListInterleaved (k g)
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
forM_ [fldr, fldl] $ \k ->
describe "Bind and compose" $
bindAndComposeHierarchy toListAsync (k g)
forM_ [(<>), (<=>), (<|), (<|>)] $ \g ->
forM_ [fldr, fldl] $ \k ->
describe "Bind and compose" $
bindAndComposeHierarchy toListParallel (k g)
-- Nest two lists using different styles of product compositions
it "Nests two streams using monadic serial composition" nestTwoSerial
it "Nests two streams using monadic interleaved composition" nestTwoInterleaved
it "Nests two streams using monadic async composition" nestTwoAsync
it "Nests two streams using monadic parallel composition" nestTwoParallel
it "Nests two streams using applicative serial composition" nestTwoSerialApp
it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp
it "Nests two streams using applicative async composition" nestTwoAsyncApp
it "Nests two streams using applicative parallel composition" nestTwoParallelApp
it "Nests two streams using Num serial composition" nestTwoSerialNum
it "Nests two streams using Num interleaved composition" nestTwoInterleavedNum
it "Nests two streams using Num async composition" nestTwoAsyncNum
-- This test fails intermittently, need to investigate
-- it "Nests two streams using Num parallel composition" nestTwoParallelNum
---------------------------------------------------------------------------
-- TBD Bind and Bind combinations
---------------------------------------------------------------------------
-- TBD combine all binds and all compose in one example
describe "Miscellaneous combined examples" mixedOps
---------------------------------------------------------------------------
-- Stream operations
---------------------------------------------------------------------------
-- XXX for streams other than StreamT
describe "Stream Ops empty" $ streamOperations makeEmptyStream
describe "Stream ops singleton constr" $ streamOperations makeSingletonStream1
describe "Stream ops singleton folded" $ streamOperations makeSingletonStream2
describe "Stream Ops constr" $ streamOperations makeStream1
describe "Stream Ops folded" $ streamOperations $ makeStream2
((<>) :: StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
describe "Serial zipping" $
zipOps A.zipWith A.zipWithM zipping
describe "Async zipping" $
zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync
makeEmptyStream :: (StreamT IO Int, [Int], Int)
makeEmptyStream = (A.nil, [], 0)
makeSingletonStream1 :: (StreamT IO Int, [Int], Int)
makeSingletonStream1 = (1 `A.cons` A.nil, [1], 1)
makeSingletonStream2 :: (StreamT IO Int, [Int], Int)
makeSingletonStream2 = (return 1, [1], 1)
-- Streams that indicate an end via the stop continuation
makeStream1 :: (StreamT IO Int, [Int], Int)
makeStream1 =
let list = [1..10]
stream = A.each list
in (stream, list, 10)
-- Streams that indicate an end via the yield continuation
makeStream2 :: (Streaming t, Monad (t IO))
=> (t IO Int -> t IO Int -> t IO Int)
-> (t IO Int, [Int], Int)
makeStream2 f =
let list = [1..10]
stream = foldMapWith f return list
in (stream, list, 10)
nestTwoSerial :: Expectation
nestTwoSerial =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListSerial (do
x <- s1
y <- s2
return (x + y)
) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
nestTwoSerialApp :: Expectation
nestTwoSerialApp =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListSerial ((+) <$> s1 <*> s2)
`shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
nestTwoSerialNum :: Expectation
nestTwoSerialNum =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListSerial (s1 + s2)
`shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
nestTwoInterleaved :: Expectation
nestTwoInterleaved =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListInterleaved (do
x <- s1
y <- s2
return (x + y)
) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
nestTwoInterleavedApp :: Expectation
nestTwoInterleavedApp =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListInterleaved ((+) <$> s1 <*> s2)
`shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
nestTwoInterleavedNum :: Expectation
nestTwoInterleavedNum =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListInterleaved (s1 + s2)
`shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
nestTwoAsync :: Expectation
nestTwoAsync =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListAsync (do
x <- s1
y <- s2
return (x + y)
) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
nestTwoAsyncApp :: Expectation
nestTwoAsyncApp =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListAsync ((+) <$> s1 <*> s2)
`shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
nestTwoAsyncNum :: Expectation
nestTwoAsyncNum =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListAsync (s1 + s2)
`shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])
nestTwoParallel :: Expectation
nestTwoParallel =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListParallel (do
x <- s1
y <- s2
return (x + y)
) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
nestTwoParallelApp :: Expectation
nestTwoParallelApp =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListParallel ((+) <$> s1 <*> s2)
`shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
{-
nestTwoParallelNum :: Expectation
nestTwoParallelNum =
let s1 = foldMapWith (<>) return [1..4]
s2 = foldMapWith (<>) return [5..8]
in toListParallel (s1 + s2)
`shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])
-}
zipOps :: (Streaming t, Applicative (t IO))
=> (forall a b c. (a -> b -> c)
-> StreamT IO a -> StreamT IO b -> StreamT IO c)
-> (forall a b c. (a -> b -> StreamT IO c)
-> StreamT IO a -> StreamT IO b -> StreamT IO c)
-> (forall a. t IO a -> t IO a)
-> Spec
zipOps z zM app = do
it "zipWith" $
let s1 = foldMapWith (<>) return [1..10]
s2 = foldMapWith (<>) return [1..]
in toListSerial (z (+) s1 s2)
`shouldReturn` ([2,4..20] :: [Int])
it "zipWithM" $
let s1 = foldMapWith (<>) return [1..10]
s2 = foldMapWith (<>) return [1..]
in toListSerial (zM (\a b -> return (a + b)) s1 s2)
`shouldReturn` ([2,4..20] :: [Int])
it "Applicative zip" $
let s1 = adapt $ serially $ foldMapWith (<>) return [1..10]
s2 = adapt $ serially $ foldMapWith (<>) return [1..]
f = A.toList . app
functorial = f $ (+) <$> s1 <*> s2
applicative = f $ pure (+) <*> s1 <*> s2
expected = ([2,4..20] :: [Int])
in (,) <$> functorial <*> applicative
`shouldReturn` (expected, expected)
timed :: Int -> StreamT IO Int
timed x = liftIO (threadDelay (x * 100000)) >> return x
thenBind :: Spec
thenBind = do
it "Simple runStreaming and 'then' with IO" $
(runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world"))
`shouldReturn` ()
it "Then and toList" $
toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int])
type ToListType s = (forall a. Ord a => s IO a -> IO [a])
pureBind :: Monad (s IO) => ToListType s -> Spec
pureBind l = do
it "Bind and toList" $
l (return 1 `f` \x -> return 2 `f` \y -> return (x + y))
`shouldReturn` ([3] :: [Int])
where f = (>>=)
bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec
bindEmpty l = it "Binds with empty" $
(l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2))
`shouldReturn` ([] :: [Int])
where f = (>>=)
interleaveCheck
:: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
-> Spec
interleaveCheck f =
it "Interleave four" $
toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101))
`shouldReturn` ([0, 100, 1, 101])
parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec
parallelCheck f = do
it "Parallel ordering left associated" $
toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1)
`shouldReturn` ([1..4])
it "Parallel ordering right associated" $
toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1)))
`shouldReturn` ([1..4])
where event n = (liftIO $ threadDelay (n * 100000)) >> (return n)
compose
:: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
-> ([Int] -> [Int])
-> Spec
compose f srt = do
it "Compose mempty, mempty" $
(tl (mempty `f` mempty)) `shouldReturn` []
it "Compose empty, empty" $
(tl (empty `f` empty)) `shouldReturn` []
it "Compose empty at the beginning" $
(tl $ (empty `f` return 1)) `shouldReturn` [1]
it "Compose empty at the end" $
(tl $ (return 1 `f` empty)) `shouldReturn` [1]
it "Compose two" $
(tl (return 0 `f` return 1) >>= return . srt)
`shouldReturn` [0, 1]
it "Compose three - empty in the middle" $
((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt)
`shouldReturn` [0, 1]
it "Compose left associated" $
((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3))
>>= return . srt) `shouldReturn` [0, 1, 2, 3]
it "Compose right associated" $
((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3))))
>>= return . srt) `shouldReturn` [0, 1, 2, 3]
it "Compose many" $
((tl $ forEachWith f [1..100] return) >>= return . srt)
`shouldReturn` [1..100]
it "Compose hierarchical (multiple levels)" $
((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3))
`f` ((return 4 `f` return 5) `f` (return 6 `f` return 7)))
) >>= return . srt) `shouldReturn` [0..7]
where tl = toListSerial
composeAndComposeSimple
:: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
-> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
-> [[Int]]
-> Spec
composeAndComposeSimple f g answer = do
it "Compose right associated outer expr, right folded inner" $
let fold = foldMapWith g return
in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
`shouldReturn` (answer !! 0)
it "Compose left associated outer expr, right folded inner" $
let fold = foldMapWith g return
in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
`shouldReturn` (answer !! 1)
it "Compose right associated outer expr, left folded inner" $
let fold xs = foldl g empty $ map return xs
in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9])))
`shouldReturn` (answer !! 2)
it "Compose left associated outer expr, left folded inner" $
let fold xs = foldl g empty $ map return xs
in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9]))
`shouldReturn` (answer !! 3)
loops
:: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int)
-> ([Int] -> [Int])
-> ([Int] -> [Int])
-> Spec
loops f tsrt hsrt = do
it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt)
`shouldReturn` [0..3]
it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt)
`shouldReturn` [0..3]
where
loopHead x = do
-- this print line is important for the test (causes a bind)
liftIO $ putStrLn "LoopHead..."
(if x < 3 then loopHead (x + 1) else empty) `f` return x
loopTail x = do
-- this print line is important for the test (causes a bind)
liftIO $ putStrLn "LoopTail..."
return x `f` (if x < 3 then loopTail (x + 1) else empty)
bindAndComposeSimple
:: (Streaming t, Alternative (t IO), Monad (t IO))
=> (forall a. Ord a => t IO a -> IO [a])
-> (t IO Int -> t IO Int -> t IO Int)
-> Spec
bindAndComposeSimple tl g = do
it "Compose many (right fold) with bind" $
(tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id))
>>= return . sort) `shouldReturn` [1..10]
it "Compose many (left fold) with bind" $
let forL xs k = foldl g empty $ map k xs
in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id))
>>= return . sort) `shouldReturn` [1..10]
where f = (>>=)
bindAndComposeHierarchy
:: Monad (s IO) => (forall a. Ord a => s IO a -> IO [a])
-> ([s IO Int] -> s IO Int)
-> Spec
bindAndComposeHierarchy tl g = do
it "Bind and compose nested" $
(tl bindComposeNested >>= return . sort)
`shouldReturn` (sort (
[12, 18]
++ replicate 3 13
++ replicate 3 17
++ replicate 6 14
++ replicate 6 16
++ replicate 7 15) :: [Int])
where
-- bindComposeNested :: AsyncT IO Int
bindComposeNested =
let c1 = tripleCompose (return 1) (return 2) (return 3)
c2 = tripleCompose (return 4) (return 5) (return 6)
c3 = tripleCompose (return 7) (return 8) (return 9)
b = tripleBind c1 c2 c3
-- it seems to be causing a huge space leak in hspec so disabling this for now
-- c = tripleCompose b b b
-- m = tripleBind c c c
-- in m
in b
tripleCompose a b c = g [a, b, c]
tripleBind mx my mz =
mx `f` \x -> my
`f` \y -> mz
`f` \z -> return (x + y + z)
f = (>>=)
mixedOps :: Spec
mixedOps = do
it "Compose many ops" $
(toListSerial composeMixed >>= return . sort)
`shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11
,11,11,11,11,11,11,11,11,12,12,12,12,12,13
] :: [Int])
where
composeMixed :: StreamT IO Int
composeMixed = do
liftIO $ return ()
liftIO $ putStr ""
x <- return 1
y <- return 2
z <- do
x1 <- return 1 <|> return 2
liftIO $ return ()
liftIO $ putStr ""
y1 <- return 1 <| return 2
z1 <- do
x11 <- return 1 <> return 2
y11 <- return 1 <| return 2
z11 <- return 1 <=> return 2
liftIO $ return ()
liftIO $ putStr ""
return (x11 + y11 + z11)
return (x1 + y1 + z1)
return (x + y + z)
streamOperations :: Streaming t => (t IO Int, [Int], Int) -> Spec
streamOperations (stream, list, len) = do
-- Generation
it "replicateM" $ do
let x = return (1 :: Int)
str <- A.toList . serially $ A.replicateM len x
lst <- replicateM len x
return $ str == lst
`shouldReturn` True
it "iterate" $
(A.toList . serially . (A.take len) $ (A.iterate (+ 1) (0 :: Int)))
`shouldReturn` (take len $ iterate (+ 1) 0)
it "iterateM" $ do
let addM = (\ y -> return (y + 1))
A.toList . serially . (A.take len) $ A.iterateM addM (0 :: Int)
`shouldReturn` (take len $ iterate (+ 1) 0)
-- Filtering
it "filter all out" $ transform (A.filter (> len)) (filter (> len))
it "filter all in" $ transform (A.filter (<= len)) (filter (<= len))
it "filter even" $ transform (A.filter even) (filter even)
it "take all" $ transform (A.take len) (take len)
it "take none" $ transform (A.take 0) (take 0)
it "take some" $ transform (A.take $ len - 1) (take $ len - 1)
it "take one" $ transform (A.take 1) (take 1)
it "takeWhile true" $ transform (A.takeWhile (const True))
(takeWhile (const True))
it "takeWhile false" $ transform (A.takeWhile (const False))
(takeWhile (const False))
it "takeWhile < some" $ transform (A.takeWhile (< (len `div` 2)))
(takeWhile (< (len `div` 2)))
it "drop all" $ transform (A.drop len) (drop len)
it "drop none" $ transform (A.drop 0) (drop 0)
it "drop some" $ transform (A.drop $ len - 1) (drop $ len - 1)
it "drop one" $ transform (A.drop 1) (drop 1)
it "dropWhile true" $ transform (A.dropWhile (const True))
(dropWhile (const True))
it "dropWhile false" $ transform (A.dropWhile (const False))
(dropWhile (const False))
it "dropWhile < some" $ transform (A.dropWhile (< (len `div` 2)))
(dropWhile (< (len `div` 2)))
-- Transformations
it "scan left" $ transform (A.scan (+) 0 id) (scanl (+) 0)
it "reverse" $ transform A.reverse reverse
-- Elimination
it "foldl" $ elimination (A.foldl (+) 0 id) (foldl (+) 0)
it "all" $ elimination (A.all even) (all even)
it "any" $ elimination (A.any even) (any even)
it "length" $ elimination A.length length
it "elem" $ elimination (A.elem (len - 1)) (elem (len - 1))
it "elem" $ elimination (A.elem (len + 1)) (elem (len + 1))
it "notElem" $ elimination (A.notElem (len - 1)) (notElem (len - 1))
it "notElem" $ elimination (A.notElem (len + 1)) (notElem (len + 1))
it "sum" $ elimination A.sum sum
it "product" $ elimination A.product product
if list == []
then do
it "head empty" $ A.head stream `shouldReturn` Nothing
it "last empty" $ A.last stream `shouldReturn` Nothing
it "maximum empty" $ A.maximum stream `shouldReturn` Nothing
it "minimum empty" $ A.minimum stream `shouldReturn` Nothing
it "null empty" $ A.null stream `shouldReturn` True
it "tail empty" $ (A.tail stream >>= return . maybe True (const False))
`shouldReturn` True
else do
it "head nonEmpty" $ A.head stream `shouldReturn` Just (head list)
it "last nonEmpty" $ A.last stream `shouldReturn` Just (last list)
it "maximum nonEmpty" $ A.maximum stream
`shouldReturn` Just (maximum list)
it "minimum nonEmpty" $ A.minimum stream
`shouldReturn` Just (minimum list)
it "null nonEmpty" $ A.null stream `shouldReturn` False
it "tail nonEmpty" $ (A.tail stream >>= A.toList . fromJust)
`shouldReturn` tail list
where
-- XXX run on empty stream as well
transform streamOp listOp =
(A.toList $ streamOp stream) `shouldReturn` listOp list
elimination streamOp listOp = (streamOp stream) `shouldReturn` listOp list