mirror of
https://github.com/composewell/streamly.git
synced 2024-10-26 19:50:19 +03:00
189 lines
6.3 KiB
Haskell
189 lines
6.3 KiB
Haskell
{-# OPTIONS_GHC -Wno-deprecations #-}
|
|
|
|
-- |
|
|
-- Module : Streamly.Test.Prelude
|
|
-- Copyright : (c) 2020 Composewell Technologies
|
|
--
|
|
-- License : BSD-3-Clause
|
|
-- Maintainer : streamly@composewell.com
|
|
-- Stability : experimental
|
|
-- Portability : GHC
|
|
|
|
module Streamly.Test.Prelude (main) where
|
|
|
|
import Control.Concurrent (myThreadId, threadDelay)
|
|
import Control.Exception (Exception, try)
|
|
import Control.Monad.Catch (throwM)
|
|
import Control.Monad.Error.Class (throwError, MonadError)
|
|
import Control.Monad.Trans.Except (runExceptT, ExceptT)
|
|
import Data.List (sort)
|
|
import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))
|
|
import System.Random (randomIO)
|
|
import Test.Hspec as H
|
|
|
|
import Streamly.Prelude (SerialT, IsStream)
|
|
|
|
import qualified Streamly.Prelude as S
|
|
|
|
toListSerial :: SerialT IO a -> IO [a]
|
|
toListSerial = S.toList . S.fromSerial
|
|
|
|
-- XXX need to test that we have promptly cleaned up everything after the error
|
|
-- XXX We can also check the output that we are expected to get before the
|
|
-- error occurs.
|
|
|
|
newtype ExampleException = ExampleException String deriving (Eq, Show)
|
|
|
|
instance Exception ExampleException
|
|
|
|
simpleMonadError :: Spec
|
|
simpleMonadError = do
|
|
{-
|
|
it "simple runExceptT" $ do
|
|
(runExceptT $ S.drain $ return ())
|
|
`shouldReturn` (Right () :: Either String ())
|
|
it "simple runExceptT with error" $ do
|
|
(runExceptT $ S.drain $ throwError "E") `shouldReturn` Left "E"
|
|
-}
|
|
it "simple try" $
|
|
try (S.drain $ return ())
|
|
`shouldReturn` (Right () :: Either ExampleException ())
|
|
it "simple try with throw error" $
|
|
try (S.drain $ throwM $ ExampleException "E")
|
|
`shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())
|
|
|
|
_composeWithMonadError
|
|
:: ( IsStream t
|
|
, Semigroup (t (ExceptT String IO) Int)
|
|
, MonadError String (t (ExceptT String IO))
|
|
)
|
|
=> (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec
|
|
_composeWithMonadError t = do
|
|
let tl = S.toList . t
|
|
it "Compose throwError, nil" $
|
|
runExceptT (tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"
|
|
it "Compose nil, error" $
|
|
runExceptT (tl (S.nil <> throwError "E")) `shouldReturn` Left "E"
|
|
|
|
mixedOps :: Spec
|
|
mixedOps =
|
|
it "Compose many ops" $
|
|
(sort <$> toListSerial composeMixed)
|
|
`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 :: SerialT IO Int
|
|
composeMixed = do
|
|
S.fromEffect $ return ()
|
|
S.fromEffect $ putStr ""
|
|
let x = 1
|
|
let y = 2
|
|
z <- do
|
|
x1 <- S.fromWAsync $ return 1 <> return 2
|
|
S.fromEffect $ return ()
|
|
S.fromEffect $ putStr ""
|
|
y1 <- S.fromAsync $ return 1 <> return 2
|
|
z1 <- do
|
|
x11 <- return 1 <> return 2
|
|
y11 <- S.fromAsync $ return 1 <> return 2
|
|
z11 <- S.fromWSerial $ return 1 <> return 2
|
|
S.fromEffect $ return ()
|
|
S.fromEffect $ putStr ""
|
|
return (x11 + y11 + z11)
|
|
return (x1 + y1 + z1)
|
|
return (x + y + z)
|
|
|
|
mixedOpsAheadly :: Spec
|
|
mixedOpsAheadly =
|
|
it "Compose many ops" $
|
|
(sort <$> toListSerial composeMixed)
|
|
`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 :: SerialT IO Int
|
|
composeMixed = do
|
|
S.fromEffect $ return ()
|
|
S.fromEffect $ putStr ""
|
|
let x = 1
|
|
let y = 2
|
|
z <- do
|
|
x1 <- S.fromWAsync $ return 1 <> return 2
|
|
S.fromEffect $ return ()
|
|
S.fromEffect $ putStr ""
|
|
y1 <- S.fromAhead $ return 1 <> return 2
|
|
z1 <- do
|
|
x11 <- return 1 <> return 2
|
|
y11 <- S.fromAhead $ return 1 <> return 2
|
|
z11 <- S.fromParallel $ return 1 <> return 2
|
|
S.fromEffect $ return ()
|
|
S.fromEffect $ putStr ""
|
|
return (x11 + y11 + z11)
|
|
return (x1 + y1 + z1)
|
|
return (x + y + z)
|
|
|
|
-- XXX Merge both the loops.
|
|
nestedLoops :: IO ()
|
|
nestedLoops = S.drain $ do
|
|
S.fromEffect $ hSetBuffering stdout LineBuffering
|
|
x <- loop "A " 2
|
|
y <- loop "B " 2
|
|
S.fromEffect $ myThreadId >>= putStr . show
|
|
>> putStr " "
|
|
>> print (x, y)
|
|
|
|
where
|
|
|
|
-- we can just use
|
|
-- fromParallel $ mconcat $ replicate n $ fromEffect (...)
|
|
loop :: String -> Int -> SerialT IO String
|
|
loop name n = do
|
|
rnd <- S.fromEffect (randomIO :: IO Int)
|
|
let result = name <> show rnd
|
|
repeatIt = if n > 1 then loop name (n - 1) else S.nil
|
|
in return result `S.wAsync` repeatIt
|
|
|
|
parallelLoops :: IO ()
|
|
parallelLoops = do
|
|
hSetBuffering stdout LineBuffering
|
|
S.drain $ do
|
|
x <- S.take 10 $ loop "A" `S.parallel` loop "B"
|
|
S.fromEffect $ myThreadId >>= putStr . show
|
|
>> putStr " got "
|
|
>> print x
|
|
|
|
where
|
|
|
|
-- we can just use
|
|
-- fromParallel $ cycle1 $ fromEffect (...)
|
|
loop :: String -> SerialT IO (String, Int)
|
|
loop name = do
|
|
S.fromEffect $ threadDelay 1000000
|
|
rnd <- S.fromEffect (randomIO :: IO Int)
|
|
S.fromEffect $ myThreadId >>= putStr . show
|
|
>> putStr " yielding "
|
|
>> print rnd
|
|
return (name, rnd) `S.parallel` loop name
|
|
|
|
moduleName :: String
|
|
moduleName = "Prelude"
|
|
|
|
main :: IO ()
|
|
main = hspec $ H.parallel $ do
|
|
describe moduleName $ do
|
|
describe "Miscellaneous combined examples" mixedOps
|
|
describe "Miscellaneous combined examples fromAhead" mixedOpsAheadly
|
|
describe "Simple MonadError and MonadThrow" simpleMonadError
|
|
|
|
it "Nested loops" nestedLoops
|
|
it "Parallel loops" parallelLoops
|
|
{-
|
|
describe "Composed MonadError fromSerial" $ composeWithMonadError fromSerial
|
|
describe "Composed MonadError fromWSerial" $ composeWithMonadError fromWSerial
|
|
describe "Composed MonadError fromAsync" $ composeWithMonadError fromAsync
|
|
describe "Composed MonadError fromWAsync" $ composeWithMonadError fromWAsync
|
|
-}
|