streamly/test/Streamly/Test/Prelude.hs

{-# 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
    -}