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