@@ -0,0 +1,309 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+-------------------------------------------------------------------------------
5+-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
6+-- ContT) with Streamly
7+-------------------------------------------------------------------------------
8+--
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.
13+--
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
17+-- exits.
18+
19+import Control.Concurrent (threadDelay)
20+import Control.Exception (catch, SomeException)
21+import Control.Monad
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
28+import Streamly
29+import Streamly.Prelude ((|:))
30+import qualified Streamly.Prelude as S
31+
32+-------------------------------------------------------------------------------
33+-- Using MaybeT below streamly
34+-------------------------------------------------------------------------------
35+--
36+-- When streamly is on top MaybeT would terminate all iterations of
37+-- non-determinism.
38+--
39+getSequenceMaybeBelow
40+ :: ( IsStream t
41+ , Monad m
42+ , MonadTrans t
43+ , Applicative (t (MaybeT m))
44+ , MonadIO (t (MaybeT m))
45+ )
46+ => t (MaybeT m) ()
47+getSequenceMaybeBelow = do
48+ liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "
49+
50+ i <- S.fromFoldable [1..2 :: Int]
51+ liftIO $ putStrLn $ "iteration = " ++ show i
52+
53+ r1 <- liftIO getLine
54+ when (r1 /= "x") $ lift mzero
55+
56+ r2 <- liftIO getLine
57+ when (r2 /= "y") $ lift mzero
58+
59+mainMaybeBelow :: IO ()
60+mainMaybeBelow = do
61+ r <- runMaybeT (runStream getSequenceMaybeBelow)
62+ case r of
63+ Just _ -> putStrLn "Bingo"
64+ Nothing -> putStrLn "Wrong"
65+
66+-------------------------------------------------------------------------------
67+-- Using MaybeT above streamly
68+-------------------------------------------------------------------------------
69+--
70+-- When MaybeT is on top a Nothing would terminate only the current iteration
71+-- of non-determinism below.
72+--
73+-- Note that this is redundant configuration as the same behavior can be
74+-- acheived with just streamly, using mzero.
75+--
76+getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
77+getSequenceMaybeAbove = do
78+ liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "
79+
80+ i <- lift $ S.fromFoldable [1..2 :: Int]
81+ liftIO $ putStrLn $ "iteration = " ++ show i
82+
83+ r1 <- liftIO getLine
84+ when (r1 /= "x") $ mzero
85+
86+ r2 <- liftIO getLine
87+ when (r2 /= "y") $ mzero
88+
89+mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
90+mainMaybeAbove = do
91+ getSequenceMaybeAbove
92+ liftIO $ putStrLn "Bingo"
93+
94+-------------------------------------------------------------------------------
95+-- Using ExceptT below streamly
96+-------------------------------------------------------------------------------
97+--
98+-- XXX need to have a specialized liftCatch to lift catchE
99+--
100+-- Note that throwE would terminate all iterations of non-determinism
101+-- altogether.
102+getSequenceEitherBelow
103+ :: ( IsStream t
104+ , MonadTrans t
105+ , Monad m
106+ , MonadIO (t m)
107+ , MonadIO (t (ExceptT String m))
108+ )
109+ => t (ExceptT String m) ()
110+getSequenceEitherBelow = do
111+ liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "
112+
113+ i <- S.fromFoldable [1..2 :: Int]
114+ liftIO $ putStrLn $ "iteration = " ++ show i
115+
116+ r1 <- liftIO getLine
117+ when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " ++ r1
118+
119+ r2 <- liftIO getLine
120+ when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " ++ r2
121+
122+mainEitherBelow :: IO ()
123+mainEitherBelow = do
124+ -- XXX Cannot lift catchE
125+ r <- runExceptT (runStream getSequenceEitherBelow)
126+ case r of
127+ Right _ -> liftIO $ putStrLn "Bingo"
128+ Left s -> liftIO $ putStrLn s
129+
130+-------------------------------------------------------------------------------
131+-- Using ExceptT below concurrent streamly
132+-------------------------------------------------------------------------------
133+--
134+-- XXX does not work correctly yet
135+--
136+getSequenceEitherAsyncBelow
137+ :: ( IsStream t
138+ , MonadTrans t
139+ , MonadIO m
140+ , MonadAsync m
141+ , MonadIO (t m)
142+ , MonadIO (t (ExceptT String m))
143+ , Semigroup (t (ExceptT [Char] m) Integer)
144+ )
145+ => t (ExceptT String m) ()
146+getSequenceEitherAsyncBelow = do
147+ liftIO $ putStrLn "ExceptT below concurrent streamly: "
148+
149+ i <- (liftIO (threadDelay 1000)
150+ >> lift (throwE "First task")
151+ >> return 1)
152+ <> (lift (throwE "Second task") >> return 2)
153+ <> S.yield (3 :: Integer)
154+ liftIO $ putStrLn $ "iteration = " ++ show i
155+
156+mainEitherAsyncBelow :: IO ()
157+mainEitherAsyncBelow = do
158+ r <- runExceptT (runStream $ asyncly $ getSequenceEitherAsyncBelow)
159+ case r of
160+ Right _ -> liftIO $ putStrLn "Bingo"
161+ Left s -> liftIO $ putStrLn s
162+
163+-------------------------------------------------------------------------------
164+-- Using ExceptT above streamly
165+-------------------------------------------------------------------------------
166+--
167+-- When ExceptT is on top, we can lift the non-determinism of stream from
168+-- below.
169+--
170+-- Note that throwE would terminate/break only current iteration of
171+-- non-determinism and not all of them altogether.
172+--
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: "
179+
180+ i <- lift $ S.fromFoldable [1..2 :: Int]
181+ liftIO $ putStrLn $ "iteration = " ++ show i
182+
183+ r1 <- liftIO getLine
184+ when (r1 /= "x") $ throwE $ "Expecting x got: " ++ r1
185+
186+ r2 <- liftIO getLine
187+ when (r2 /= "y") $ throwE $ "Expecting y got: " ++ r2
188+
189+mainEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
190+ => ExceptT String (t m) ()
191+mainEitherAbove = do
192+ catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))
193+ (\e -> liftIO $ putStrLn e)
194+
195+-------------------------------------------------------------------------------
196+-- Using MonadThrow to throw exceptions in streamly
197+-------------------------------------------------------------------------------
198+--
199+data Unexpected = Unexpected String deriving Show
200+
201+instance Exception Unexpected
202+
203+-- Note that unlike when ExceptT is used on top, MonadThrow terminates all
204+-- iterations of non-determinism rather then just the current iteration.
205+--
206+getSequenceMonadThrow :: (IsStream t, Monad m, MonadIO (t m), MonadThrow (t m))
207+ => t m ()
208+getSequenceMonadThrow = do
209+ liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "
210+
211+ i <- S.fromFoldable [1..2 :: Int]
212+ liftIO $ putStrLn $ "iteration = " ++ show i
213+
214+ r1 <- liftIO getLine
215+ when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " ++ r1
216+
217+ r2 <- liftIO getLine
218+ when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " ++ r2
219+
220+mainMonadThrow :: IO ()
221+mainMonadThrow = do
222+ catch (runStream getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))
223+ (\(e :: SomeException) -> liftIO $ putStrLn $ show e)
224+
225+-------------------------------------------------------------------------------
226+-- Using ContT below streamly
227+-------------------------------------------------------------------------------
228+--
229+-- CallCC is the goto/setjmp/longjmp equivalent
230+-- Allows us to manipulate the control flow in arbitrary ways
231+--
232+-- XXX need to have a specialized liftCallCC to actually lift callCC
233+--
234+getSequenceContBelow
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: "
239+
240+ i <- S.fromFoldable [1..2 :: Int]
241+ liftIO $ putStrLn $ "iteration = " ++ show i
242+
243+ r <- lift $ callCC $ \exit -> do
244+ r1 <- liftIO getLine
245+ _ <- if r1 /= "x"
246+ then exit $ Left $ "Expecting x got: " ++ r1
247+ else return $ Right ()
248+
249+ r2 <- liftIO getLine
250+ if r2 /= "y"
251+ then exit $ Left $ "Expecting y got: " ++ r2
252+ else return $ Right ()
253+ liftIO $ putStrLn $ "done iteration = " ++ show i
254+ return r
255+
256+mainContBelow
257+ :: (IsStream t, MonadIO m, MonadTrans t, MonadIO (t (ContT r m)))
258+ => t (ContT r m) ()
259+mainContBelow = do
260+ r <- getSequenceContBelow
261+ case r of
262+ Right _ -> liftIO $ putStrLn "Bingo"
263+ Left s -> liftIO $ putStrLn s
264+
265+-------------------------------------------------------------------------------
266+-- Using ContT above streamly
267+-------------------------------------------------------------------------------
268+--
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: "
273+
274+ i <- lift $ S.fromFoldable [1..2 :: Int]
275+ liftIO $ putStrLn $ "iteration = " ++ show i
276+
277+ callCC $ \exit -> do
278+ r1 <- liftIO getLine
279+ _ <- if r1 /= "x"
280+ then exit $ Left $ "Expecting x got: " ++ r1
281+ else return $ Right ()
282+
283+ r2 <- liftIO getLine
284+ if r2 /= "y"
285+ then exit $ Left $ "Expecting y got: " ++ r2
286+ else return $ Right ()
287+
288+mainContAbove :: (IsStream t, Monad m, MonadIO (t m)) => ContT r (t m) ()
289+mainContAbove = do
290+ r <- getSequenceContAbove
291+ case r of
292+ Right _ -> liftIO $ putStrLn "Bingo"
293+ Left s -> liftIO $ putStrLn s
294+
295+-------------------------------------------------------------------------------
296+-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
297+-- ContT) with Streamly
298+-------------------------------------------------------------------------------
299+
300+main :: IO ()
301+main = do
302+ mainMaybeBelow
303+ runStream $ runMaybeT mainMaybeAbove
304+ runContT (runStream mainContBelow) return
305+ runStream (runContT mainContAbove return)
306+ mainEitherBelow
307+ runStream (runExceptT mainEitherAbove)
308+ mainMonadThrow
309+ mainEitherAsyncBelow