@@ -0,0 +1,309 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
4+-------------------------------------------------------------------------------
5+-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
6+-- ContT) with Streamly
7+-------------------------------------------------------------------------------
9+-- Streamly streams are non-determinism (nested looping) monads. We can use a
10+-- control flow monad on top or streamly on top depending on whether we want to
11+-- superimpose control flow manipulation on top of non-deterministic
12+-- composition or vice-versa.
14+-- This file provides an example where we enter a sequence of characters "x",
15+-- and "y" on separate lines, on the command line. When any other sequence is
16+-- entered the control flow short circuits at the first non-matching char and
19+import Control.Concurrent (threadDelay)
20+import Control.Exception (catch, SomeException)
22+import Control.Monad.Catch (MonadThrow, throwM, Exception)
23+import Control.Monad.IO.Class
24+import Control.Monad.Trans.Class
25+import Control.Monad.Trans.Maybe
26+import Control.Monad.Trans.Except
27+import Control.Monad.Trans.Cont
29+import Streamly.Prelude ((|:))
30+import qualified Streamly.Prelude as S
32+-------------------------------------------------------------------------------
33+-- Using MaybeT below streamly
34+-------------------------------------------------------------------------------
36+-- When streamly is on top MaybeT would terminate all iterations of
43+ , Applicative (t (MaybeT m))
44+ , MonadIO (t (MaybeT m))
47+getSequenceMaybeBelow = do
48+ liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "
50+ i <- S.fromFoldable [1..2 :: Int]
51+ liftIO $ putStrLn $ "iteration = " ++ show i
54+ when (r1 /= "x") $ lift mzero
57+ when (r2 /= "y") $ lift mzero
59+mainMaybeBelow :: IO ()
61+ r <- runMaybeT (runStream getSequenceMaybeBelow)
63+ Just _ -> putStrLn "Bingo"
64+ Nothing -> putStrLn "Wrong"
66+-------------------------------------------------------------------------------
67+-- Using MaybeT above streamly
68+-------------------------------------------------------------------------------
70+-- When MaybeT is on top a Nothing would terminate only the current iteration
71+-- of non-determinism below.
73+-- Note that this is redundant configuration as the same behavior can be
74+-- acheived with just streamly, using mzero.
76+getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
77+getSequenceMaybeAbove = do
78+ liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "
80+ i <- lift $ S.fromFoldable [1..2 :: Int]
81+ liftIO $ putStrLn $ "iteration = " ++ show i
84+ when (r1 /= "x") $ mzero
87+ when (r2 /= "y") $ mzero
89+mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
91+ getSequenceMaybeAbove
92+ liftIO $ putStrLn "Bingo"
94+-------------------------------------------------------------------------------
95+-- Using ExceptT below streamly
96+-------------------------------------------------------------------------------
98+-- XXX need to have a specialized liftCatch to lift catchE
100+-- Note that throwE would terminate all iterations of non-determinism
102+getSequenceEitherBelow
107+ , MonadIO (t (ExceptT String m))
109+ => t (ExceptT String m) ()
110+getSequenceEitherBelow = do
111+ liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "
113+ i <- S.fromFoldable [1..2 :: Int]
114+ liftIO $ putStrLn $ "iteration = " ++ show i
116+ r1 <- liftIO getLine
117+ when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " ++ r1
119+ r2 <- liftIO getLine
120+ when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " ++ r2
122+mainEitherBelow :: IO ()
124+ -- XXX Cannot lift catchE
125+ r <- runExceptT (runStream getSequenceEitherBelow)
127+ Right _ -> liftIO $ putStrLn "Bingo"
128+ Left s -> liftIO $ putStrLn s
130+-------------------------------------------------------------------------------
131+-- Using ExceptT below concurrent streamly
132+-------------------------------------------------------------------------------
134+-- XXX does not work correctly yet
136+getSequenceEitherAsyncBelow
142+ , MonadIO (t (ExceptT String m))
143+ , Semigroup (t (ExceptT [Char] m) Integer)
145+ => t (ExceptT String m) ()
146+getSequenceEitherAsyncBelow = do
147+ liftIO $ putStrLn "ExceptT below concurrent streamly: "
149+ i <- (liftIO (threadDelay 1000)
150+ >> lift (throwE "First task")
152+ <> (lift (throwE "Second task") >> return 2)
153+ <> S.yield (3 :: Integer)
154+ liftIO $ putStrLn $ "iteration = " ++ show i
156+mainEitherAsyncBelow :: IO ()
157+mainEitherAsyncBelow = do
158+ r <- runExceptT (runStream $ asyncly $ getSequenceEitherAsyncBelow)
160+ Right _ -> liftIO $ putStrLn "Bingo"
161+ Left s -> liftIO $ putStrLn s
163+-------------------------------------------------------------------------------
164+-- Using ExceptT above streamly
165+-------------------------------------------------------------------------------
167+-- When ExceptT is on top, we can lift the non-determinism of stream from
170+-- Note that throwE would terminate/break only current iteration of
171+-- non-determinism and not all of them altogether.
173+-- Here we can use catchE directly but will have to use monad-control to lift
174+-- stream operations with stream arguments.
175+getSequenceEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
176+ => ExceptT String (t m) ()
177+getSequenceEitherAbove = do
178+ liftIO $ putStrLn "ExceptT above streamly: Enter one char per line: "
180+ i <- lift $ S.fromFoldable [1..2 :: Int]
181+ liftIO $ putStrLn $ "iteration = " ++ show i
183+ r1 <- liftIO getLine
184+ when (r1 /= "x") $ throwE $ "Expecting x got: " ++ r1
186+ r2 <- liftIO getLine
187+ when (r2 /= "y") $ throwE $ "Expecting y got: " ++ r2
189+mainEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
190+ => ExceptT String (t m) ()
192+ catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))
193+ (\e -> liftIO $ putStrLn e)
195+-------------------------------------------------------------------------------
196+-- Using MonadThrow to throw exceptions in streamly
197+-------------------------------------------------------------------------------
199+data Unexpected = Unexpected String deriving Show
201+instance Exception Unexpected
203+-- Note that unlike when ExceptT is used on top, MonadThrow terminates all
204+-- iterations of non-determinism rather then just the current iteration.
206+getSequenceMonadThrow :: (IsStream t, Monad m, MonadIO (t m), MonadThrow (t m))
208+getSequenceMonadThrow = do
209+ liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "
211+ i <- S.fromFoldable [1..2 :: Int]
212+ liftIO $ putStrLn $ "iteration = " ++ show i
214+ r1 <- liftIO getLine
215+ when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " ++ r1
217+ r2 <- liftIO getLine
218+ when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " ++ r2
220+mainMonadThrow :: IO ()
222+ catch (runStream getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))
223+ (\(e :: SomeException) -> liftIO $ putStrLn $ show e)
225+-------------------------------------------------------------------------------
226+-- Using ContT below streamly
227+-------------------------------------------------------------------------------
229+-- CallCC is the goto/setjmp/longjmp equivalent
230+-- Allows us to manipulate the control flow in arbitrary ways
232+-- XXX need to have a specialized liftCallCC to actually lift callCC
235+ :: (IsStream t, MonadTrans t, MonadIO m, MonadIO (t (ContT r m)))
236+ => t (ContT r m) (Either String ())
237+getSequenceContBelow = do
238+ liftIO $ putStrLn "ContT below streamly: Enter one char per line: "
240+ i <- S.fromFoldable [1..2 :: Int]
241+ liftIO $ putStrLn $ "iteration = " ++ show i
243+ r <- lift $ callCC $ \exit -> do
244+ r1 <- liftIO getLine
246+ then exit $ Left $ "Expecting x got: " ++ r1
247+ else return $ Right ()
249+ r2 <- liftIO getLine
251+ then exit $ Left $ "Expecting y got: " ++ r2
252+ else return $ Right ()
253+ liftIO $ putStrLn $ "done iteration = " ++ show i
257+ :: (IsStream t, MonadIO m, MonadTrans t, MonadIO (t (ContT r m)))
260+ r <- getSequenceContBelow
262+ Right _ -> liftIO $ putStrLn "Bingo"
263+ Left s -> liftIO $ putStrLn s
265+-------------------------------------------------------------------------------
266+-- Using ContT above streamly
267+-------------------------------------------------------------------------------
269+getSequenceContAbove :: (IsStream t, Monad m, MonadIO (t m))
270+ => ContT r (t m) (Either String ())
271+getSequenceContAbove = do
272+ liftIO $ putStrLn "ContT above streamly: Enter one char per line: "
274+ i <- lift $ S.fromFoldable [1..2 :: Int]
275+ liftIO $ putStrLn $ "iteration = " ++ show i
277+ callCC $ \exit -> do
278+ r1 <- liftIO getLine
280+ then exit $ Left $ "Expecting x got: " ++ r1
281+ else return $ Right ()
283+ r2 <- liftIO getLine
285+ then exit $ Left $ "Expecting y got: " ++ r2
286+ else return $ Right ()
288+mainContAbove :: (IsStream t, Monad m, MonadIO (t m)) => ContT r (t m) ()
290+ r <- getSequenceContAbove
292+ Right _ -> liftIO $ putStrLn "Bingo"
293+ Left s -> liftIO $ putStrLn s
295+-------------------------------------------------------------------------------
296+-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
297+-- ContT) with Streamly
298+-------------------------------------------------------------------------------
303+ runStream $ runMaybeT mainMaybeAbove
304+ runContT (runStream mainContBelow) return
305+ runStream (runContT mainContAbove return)
307+ runStream (runExceptT mainEitherAbove)
309+ mainEitherAsyncBelow