git.iko.soy/streamly
on dbc1956 help sign in
streamly/examples/ControlFlow.hs
309 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 Streamly.Prelude ((|:))
30import qualified Streamly.Prelude as S
32-------------------------------------------------------------------------------
33-- Using MaybeT below streamly
34-------------------------------------------------------------------------------
35--
36-- When streamly is on top MaybeT would terminate all iterations of
37-- non-determinism.
38--
39getSequenceMaybeBelow
40 :: ( IsStream t
41 , Monad m
42 , MonadTrans t
43 , Applicative (t (MaybeT m))
44 , MonadIO (t (MaybeT m))
45 )
46 => t (MaybeT m) ()
47getSequenceMaybeBelow = 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
53 r1 <- liftIO getLine
54 when (r1 /= "x") $ lift mzero
56 r2 <- liftIO getLine
57 when (r2 /= "y") $ lift mzero
59mainMaybeBelow :: IO ()
60mainMaybeBelow = do
61 r <- runMaybeT (runStream getSequenceMaybeBelow)
62 case r of
63 Just _ -> putStrLn "Bingo"
64 Nothing -> putStrLn "Wrong"
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--
76getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
77getSequenceMaybeAbove = 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
83 r1 <- liftIO getLine
84 when (r1 /= "x") mzero
86 r2 <- liftIO getLine
87 when (r2 /= "y") mzero
89mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
90mainMaybeAbove = do
91 getSequenceMaybeAbove
92 liftIO $ putStrLn "Bingo"
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.
102getSequenceEitherBelow
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) ()
110getSequenceEitherBelow = 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
122mainEitherBelow :: IO ()
123mainEitherBelow = 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
130-------------------------------------------------------------------------------
131-- Using ExceptT below concurrent streamly
132-------------------------------------------------------------------------------
133--
134-- XXX does not work correctly yet
135--
136getSequenceEitherAsyncBelow
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 String m) Integer)
144 )
145 => t (ExceptT String m) ()
146getSequenceEitherAsyncBelow = do
147 liftIO $ putStrLn "ExceptT below concurrent streamly: "
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
156mainEitherAsyncBelow :: IO ()
157mainEitherAsyncBelow = do
158 r <- runExceptT (runStream $ asyncly getSequenceEitherAsyncBelow)
159 case r of
160 Right _ -> liftIO $ putStrLn "Bingo"
161 Left s -> liftIO $ putStrLn s
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.
175getSequenceEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
176 => ExceptT String (t m) ()
177getSequenceEitherAbove = 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
189mainEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
190 => ExceptT String (t m) ()
191mainEitherAbove =
192 catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))
193 (liftIO . putStrLn)
195-------------------------------------------------------------------------------
196-- Using MonadThrow to throw exceptions in streamly
197-------------------------------------------------------------------------------
198--
199newtype Unexpected = Unexpected String deriving Show
201instance 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.
205--
206getSequenceMonadThrow :: (IsStream t, Monad m, MonadIO (t m), MonadThrow (t m))
207 => t m ()
208getSequenceMonadThrow = 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
220mainMonadThrow :: IO ()
221mainMonadThrow =
222 catch (runStream getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))
223 (\(e :: SomeException) -> liftIO $ print e)
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--
234getSequenceContBelow
235 :: (IsStream t, MonadTrans t, MonadIO m, MonadIO (t (ContT r m)))
236 => t (ContT r m) (Either String ())
237getSequenceContBelow = 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
245 _ <- if r1 /= "x"
246 then exit $ Left $ "Expecting x got: " <> r1
247 else return $ Right ()
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
256mainContBelow
257 :: (IsStream t, MonadIO m, MonadTrans t, MonadIO (t (ContT r m)))
258 => t (ContT r m) ()
259mainContBelow = do
260 r <- getSequenceContBelow
261 case r of
262 Right _ -> liftIO $ putStrLn "Bingo"
263 Left s -> liftIO $ putStrLn s
265-------------------------------------------------------------------------------
266-- Using ContT above streamly
267-------------------------------------------------------------------------------
268--
269getSequenceContAbove :: (IsStream t, Monad m, MonadIO (t m))
270 => ContT r (t m) (Either String ())
271getSequenceContAbove = 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
279 _ <- if r1 /= "x"
280 then exit $ Left $ "Expecting x got: " <> r1
281 else return $ Right ()
283 r2 <- liftIO getLine
284 if r2 /= "y"
285 then exit $ Left $ "Expecting y got: " <> r2
286 else return $ Right ()
288mainContAbove :: (IsStream t, Monad m, MonadIO (t m)) => ContT r (t m) ()
289mainContAbove = do
290 r <- getSequenceContAbove
291 case r of
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-------------------------------------------------------------------------------
300main :: IO ()
301main = 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