mirror of
https://github.com/composewell/streamly.git
synced 2024-09-21 00:20:08 +03:00
310 lines
10 KiB
Haskell
310 lines
10 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
|
|
-- ContT) with Streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- Streamly streams are non-determinism (nested looping) monads. We can use a
|
|
-- control flow monad on top or streamly on top depending on whether we want to
|
|
-- superimpose control flow manipulation on top of non-deterministic
|
|
-- composition or vice-versa.
|
|
--
|
|
-- This file provides an example where we enter a sequence of characters "x",
|
|
-- and "y" on separate lines, on the command line. When any other sequence is
|
|
-- entered the control flow short circuits at the first non-matching char and
|
|
-- exits.
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Exception (catch, SomeException)
|
|
import Control.Monad
|
|
import Control.Monad.Catch (MonadThrow, throwM, Exception)
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Class
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Cont
|
|
import Streamly
|
|
import Streamly.Prelude ((|:))
|
|
import qualified Streamly.Prelude as S
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using MaybeT below streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- When streamly is on top MaybeT would terminate all iterations of
|
|
-- non-determinism.
|
|
--
|
|
getSequenceMaybeBelow
|
|
:: ( IsStream t
|
|
, Monad m
|
|
, MonadTrans t
|
|
, Applicative (t (MaybeT m))
|
|
, MonadIO (t (MaybeT m))
|
|
)
|
|
=> t (MaybeT m) ()
|
|
getSequenceMaybeBelow = do
|
|
liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "
|
|
|
|
i <- S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
r1 <- liftIO getLine
|
|
when (r1 /= "x") $ lift mzero
|
|
|
|
r2 <- liftIO getLine
|
|
when (r2 /= "y") $ lift mzero
|
|
|
|
mainMaybeBelow :: IO ()
|
|
mainMaybeBelow = do
|
|
r <- runMaybeT (runStream getSequenceMaybeBelow)
|
|
case r of
|
|
Just _ -> putStrLn "Bingo"
|
|
Nothing -> putStrLn "Wrong"
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using MaybeT above streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- When MaybeT is on top a Nothing would terminate only the current iteration
|
|
-- of non-determinism below.
|
|
--
|
|
-- Note that this is redundant configuration as the same behavior can be
|
|
-- acheived with just streamly, using mzero.
|
|
--
|
|
getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
|
|
getSequenceMaybeAbove = do
|
|
liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "
|
|
|
|
i <- lift $ S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
r1 <- liftIO getLine
|
|
when (r1 /= "x") $ mzero
|
|
|
|
r2 <- liftIO getLine
|
|
when (r2 /= "y") $ mzero
|
|
|
|
mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
|
|
mainMaybeAbove = do
|
|
getSequenceMaybeAbove
|
|
liftIO $ putStrLn "Bingo"
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using ExceptT below streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- XXX need to have a specialized liftCatch to lift catchE
|
|
--
|
|
-- Note that throwE would terminate all iterations of non-determinism
|
|
-- altogether.
|
|
getSequenceEitherBelow
|
|
:: ( IsStream t
|
|
, MonadTrans t
|
|
, Monad m
|
|
, MonadIO (t m)
|
|
, MonadIO (t (ExceptT String m))
|
|
)
|
|
=> t (ExceptT String m) ()
|
|
getSequenceEitherBelow = do
|
|
liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "
|
|
|
|
i <- S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
r1 <- liftIO getLine
|
|
when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " ++ r1
|
|
|
|
r2 <- liftIO getLine
|
|
when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " ++ r2
|
|
|
|
mainEitherBelow :: IO ()
|
|
mainEitherBelow = do
|
|
-- XXX Cannot lift catchE
|
|
r <- runExceptT (runStream getSequenceEitherBelow)
|
|
case r of
|
|
Right _ -> liftIO $ putStrLn "Bingo"
|
|
Left s -> liftIO $ putStrLn s
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using ExceptT below concurrent streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- XXX does not work correctly yet
|
|
--
|
|
getSequenceEitherAsyncBelow
|
|
:: ( IsStream t
|
|
, MonadTrans t
|
|
, MonadIO m
|
|
, MonadAsync m
|
|
, MonadIO (t m)
|
|
, MonadIO (t (ExceptT String m))
|
|
, Semigroup (t (ExceptT [Char] m) Integer)
|
|
)
|
|
=> t (ExceptT String m) ()
|
|
getSequenceEitherAsyncBelow = do
|
|
liftIO $ putStrLn "ExceptT below concurrent streamly: "
|
|
|
|
i <- (liftIO (threadDelay 1000)
|
|
>> lift (throwE "First task")
|
|
>> return 1)
|
|
<> (lift (throwE "Second task") >> return 2)
|
|
<> S.yield (3 :: Integer)
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
mainEitherAsyncBelow :: IO ()
|
|
mainEitherAsyncBelow = do
|
|
r <- runExceptT (runStream $ asyncly $ getSequenceEitherAsyncBelow)
|
|
case r of
|
|
Right _ -> liftIO $ putStrLn "Bingo"
|
|
Left s -> liftIO $ putStrLn s
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using ExceptT above streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- When ExceptT is on top, we can lift the non-determinism of stream from
|
|
-- below.
|
|
--
|
|
-- Note that throwE would terminate/break only current iteration of
|
|
-- non-determinism and not all of them altogether.
|
|
--
|
|
-- Here we can use catchE directly but will have to use monad-control to lift
|
|
-- stream operations with stream arguments.
|
|
getSequenceEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
|
|
=> ExceptT String (t m) ()
|
|
getSequenceEitherAbove = do
|
|
liftIO $ putStrLn "ExceptT above streamly: Enter one char per line: "
|
|
|
|
i <- lift $ S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
r1 <- liftIO getLine
|
|
when (r1 /= "x") $ throwE $ "Expecting x got: " ++ r1
|
|
|
|
r2 <- liftIO getLine
|
|
when (r2 /= "y") $ throwE $ "Expecting y got: " ++ r2
|
|
|
|
mainEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
|
|
=> ExceptT String (t m) ()
|
|
mainEitherAbove = do
|
|
catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))
|
|
(\e -> liftIO $ putStrLn e)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using MonadThrow to throw exceptions in streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
data Unexpected = Unexpected String deriving Show
|
|
|
|
instance Exception Unexpected
|
|
|
|
-- Note that unlike when ExceptT is used on top, MonadThrow terminates all
|
|
-- iterations of non-determinism rather then just the current iteration.
|
|
--
|
|
getSequenceMonadThrow :: (IsStream t, Monad m, MonadIO (t m), MonadThrow (t m))
|
|
=> t m ()
|
|
getSequenceMonadThrow = do
|
|
liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "
|
|
|
|
i <- S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
r1 <- liftIO getLine
|
|
when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " ++ r1
|
|
|
|
r2 <- liftIO getLine
|
|
when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " ++ r2
|
|
|
|
mainMonadThrow :: IO ()
|
|
mainMonadThrow = do
|
|
catch (runStream getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))
|
|
(\(e :: SomeException) -> liftIO $ putStrLn $ show e)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using ContT below streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
-- CallCC is the goto/setjmp/longjmp equivalent
|
|
-- Allows us to manipulate the control flow in arbitrary ways
|
|
--
|
|
-- XXX need to have a specialized liftCallCC to actually lift callCC
|
|
--
|
|
getSequenceContBelow
|
|
:: (IsStream t, MonadTrans t, MonadIO m, MonadIO (t (ContT r m)))
|
|
=> t (ContT r m) (Either String ())
|
|
getSequenceContBelow = do
|
|
liftIO $ putStrLn "ContT below streamly: Enter one char per line: "
|
|
|
|
i <- S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
r <- lift $ callCC $ \exit -> do
|
|
r1 <- liftIO getLine
|
|
_ <- if r1 /= "x"
|
|
then exit $ Left $ "Expecting x got: " ++ r1
|
|
else return $ Right ()
|
|
|
|
r2 <- liftIO getLine
|
|
if r2 /= "y"
|
|
then exit $ Left $ "Expecting y got: " ++ r2
|
|
else return $ Right ()
|
|
liftIO $ putStrLn $ "done iteration = " ++ show i
|
|
return r
|
|
|
|
mainContBelow
|
|
:: (IsStream t, MonadIO m, MonadTrans t, MonadIO (t (ContT r m)))
|
|
=> t (ContT r m) ()
|
|
mainContBelow = do
|
|
r <- getSequenceContBelow
|
|
case r of
|
|
Right _ -> liftIO $ putStrLn "Bingo"
|
|
Left s -> liftIO $ putStrLn s
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Using ContT above streamly
|
|
-------------------------------------------------------------------------------
|
|
--
|
|
getSequenceContAbove :: (IsStream t, Monad m, MonadIO (t m))
|
|
=> ContT r (t m) (Either String ())
|
|
getSequenceContAbove = do
|
|
liftIO $ putStrLn "ContT above streamly: Enter one char per line: "
|
|
|
|
i <- lift $ S.fromFoldable [1..2 :: Int]
|
|
liftIO $ putStrLn $ "iteration = " ++ show i
|
|
|
|
callCC $ \exit -> do
|
|
r1 <- liftIO getLine
|
|
_ <- if r1 /= "x"
|
|
then exit $ Left $ "Expecting x got: " ++ r1
|
|
else return $ Right ()
|
|
|
|
r2 <- liftIO getLine
|
|
if r2 /= "y"
|
|
then exit $ Left $ "Expecting y got: " ++ r2
|
|
else return $ Right ()
|
|
|
|
mainContAbove :: (IsStream t, Monad m, MonadIO (t m)) => ContT r (t m) ()
|
|
mainContAbove = do
|
|
r <- getSequenceContAbove
|
|
case r of
|
|
Right _ -> liftIO $ putStrLn "Bingo"
|
|
Left s -> liftIO $ putStrLn s
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
|
|
-- ContT) with Streamly
|
|
-------------------------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main = do
|
|
mainMaybeBelow
|
|
runStream $ runMaybeT mainMaybeAbove
|
|
runContT (runStream mainContBelow) return
|
|
runStream (runContT mainContAbove return)
|
|
mainEitherBelow
|
|
runStream (runExceptT mainEitherAbove)
|
|
mainMonadThrow
|
|
mainEitherAsyncBelow
|