git.iko.soy/streamly
on fa8a2cf help sign in
streamly/examples/ControlFlow.hs
303 lines 10 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 , MonadIO (t (MaybeT m))
43 )
44 => t (MaybeT m) ()
45getSequenceMaybeBelow = do
46 liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "
48 i <- S.fromFoldable [1..2 :: Int]
49 liftIO $ putStrLn $ "iteration = " <> show i
51 r1 <- liftIO getLine
52 when (r1 /= "x") $ lift mzero
54 r2 <- liftIO getLine
55 when (r2 /= "y") $ lift mzero
57mainMaybeBelow :: IO ()
58mainMaybeBelow = do
59 r <- runMaybeT (S.drain getSequenceMaybeBelow)
60 case r of
61 Just _ -> putStrLn "Bingo"
62 Nothing -> putStrLn "Wrong"
64-------------------------------------------------------------------------------
65-- Using MaybeT above streamly
66-------------------------------------------------------------------------------
67--
68-- When MaybeT is on top a Nothing would terminate only the current iteration
69-- of non-determinism below.
70--
71-- Note that this is redundant configuration as the same behavior can be
72-- achieved with just streamly, using mzero.
73--
74getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
75getSequenceMaybeAbove = do
76 liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "
78 i <- lift $ S.fromFoldable [1..2 :: Int]
79 liftIO $ putStrLn $ "iteration = " <> show i
81 r1 <- liftIO getLine
82 when (r1 /= "x") mzero
84 r2 <- liftIO getLine
85 when (r2 /= "y") mzero
87mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
88mainMaybeAbove = do
89 getSequenceMaybeAbove
90 liftIO $ putStrLn "Bingo"
92-------------------------------------------------------------------------------
93-- Using ExceptT below streamly
94-------------------------------------------------------------------------------
95--
96-- XXX need to have a specialized liftCatch to lift catchE
97--
98-- Note that throwE would terminate all iterations of non-determinism
99-- altogether.
100getSequenceEitherBelow
101 :: ( IsStream t
102 , MonadTrans t
103 , Monad m
104 , MonadIO (t (ExceptT String m))
105 )
106 => t (ExceptT String m) ()
107getSequenceEitherBelow = do
108 liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "
110 i <- S.fromFoldable [1..2 :: Int]
111 liftIO $ putStrLn $ "iteration = " <> show i
113 r1 <- liftIO getLine
114 when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " <> r1
116 r2 <- liftIO getLine
117 when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " <> r2
119mainEitherBelow :: IO ()
120mainEitherBelow = do
121 -- XXX Cannot lift catchE
122 r <- runExceptT (S.drain getSequenceEitherBelow)
123 case r of
124 Right _ -> liftIO $ putStrLn "Bingo"
125 Left s -> liftIO $ putStrLn s
127-------------------------------------------------------------------------------
128-- Using ExceptT below concurrent streamly
129-------------------------------------------------------------------------------
130--
131-- XXX does not work correctly yet
132--
133getSequenceEitherAsyncBelow
134 :: ( IsStream t
135 , MonadTrans t
136 , MonadIO m
137 , MonadIO (t (ExceptT String m))
138 , Semigroup (t (ExceptT String m) Integer)
139 )
140 => t (ExceptT String m) ()
141getSequenceEitherAsyncBelow = do
142 liftIO $ putStrLn "ExceptT below concurrent streamly: "
144 i <- (liftIO (threadDelay 1000)
145 >> lift (throwE "First task")
146 >> return 1)
147 <> (lift (throwE "Second task") >> return 2)
148 <> S.yield (3 :: Integer)
149 liftIO $ putStrLn $ "iteration = " <> show i
151mainEitherAsyncBelow :: IO ()
152mainEitherAsyncBelow = do
153 r <- runExceptT (S.drain $ asyncly getSequenceEitherAsyncBelow)
154 case r of
155 Right _ -> liftIO $ putStrLn "Bingo"
156 Left s -> liftIO $ putStrLn s
158-------------------------------------------------------------------------------
159-- Using ExceptT above streamly
160-------------------------------------------------------------------------------
161--
162-- When ExceptT is on top, we can lift the non-determinism of stream from
163-- below.
164--
165-- Note that throwE would terminate/break only current iteration of
166-- non-determinism and not all of them altogether.
167--
168-- Here we can use catchE directly but will have to use monad-control to lift
169-- stream operations with stream arguments.
170getSequenceEitherAbove :: (IsStream t, MonadIO (t m))
171 => ExceptT String (t m) ()
172getSequenceEitherAbove = do
173 liftIO $ putStrLn "ExceptT above streamly: Enter one char per line: "
175 i <- lift $ S.fromFoldable [1..2 :: Int]
176 liftIO $ putStrLn $ "iteration = " <> show i
178 r1 <- liftIO getLine
179 when (r1 /= "x") $ throwE $ "Expecting x got: " <> r1
181 r2 <- liftIO getLine
182 when (r2 /= "y") $ throwE $ "Expecting y got: " <> r2
184mainEitherAbove :: (IsStream t, MonadIO (t m)) => ExceptT String (t m) ()
185mainEitherAbove =
186 catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))
187 (liftIO . putStrLn)
189-------------------------------------------------------------------------------
190-- Using MonadThrow to throw exceptions in streamly
191-------------------------------------------------------------------------------
192--
193newtype Unexpected = Unexpected String deriving Show
195instance Exception Unexpected
197-- Note that unlike when ExceptT is used on top, MonadThrow terminates all
198-- iterations of non-determinism rather then just the current iteration.
199--
200getSequenceMonadThrow :: (IsStream t, MonadIO (t m), MonadThrow (t m))
201 => t m ()
202getSequenceMonadThrow = do
203 liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "
205 i <- S.fromFoldable [1..2 :: Int]
206 liftIO $ putStrLn $ "iteration = " <> show i
208 r1 <- liftIO getLine
209 when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " <> r1
211 r2 <- liftIO getLine
212 when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " <> r2
214mainMonadThrow :: IO ()
215mainMonadThrow =
216 catch (S.drain getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))
217 (\(e :: SomeException) -> liftIO $ print e)
219-------------------------------------------------------------------------------
220-- Using ContT below streamly
221-------------------------------------------------------------------------------
222--
223-- CallCC is the goto/setjmp/longjmp equivalent
224-- Allows us to manipulate the control flow in arbitrary ways
225--
226-- XXX need to have a specialized liftCallCC to actually lift callCC
227--
228getSequenceContBelow
229 :: (IsStream t, MonadTrans t, MonadIO m, MonadIO (t (ContT r m)))
230 => t (ContT r m) (Either String ())
231getSequenceContBelow = do
232 liftIO $ putStrLn "ContT below streamly: Enter one char per line: "
234 i <- S.fromFoldable [1..2 :: Int]
235 liftIO $ putStrLn $ "iteration = " <> show i
237 r <- lift $ callCC $ \exit -> do
238 r1 <- liftIO getLine
239 _ <- if r1 /= "x"
240 then exit $ Left $ "Expecting x got: " <> r1
241 else return $ Right ()
243 r2 <- liftIO getLine
244 if r2 /= "y"
245 then exit $ Left $ "Expecting y got: " <> r2
246 else return $ Right ()
247 liftIO $ putStrLn $ "done iteration = " <> show i
248 return r
250mainContBelow
251 :: (IsStream t, MonadIO m, MonadTrans t, MonadIO (t (ContT r m)))
252 => t (ContT r m) ()
253mainContBelow = do
254 r <- getSequenceContBelow
255 case r of
256 Right _ -> liftIO $ putStrLn "Bingo"
257 Left s -> liftIO $ putStrLn s
259-------------------------------------------------------------------------------
260-- Using ContT above streamly
261-------------------------------------------------------------------------------
262--
263getSequenceContAbove :: (IsStream t, MonadIO (t m))
264 => ContT r (t m) (Either String ())
265getSequenceContAbove = do
266 liftIO $ putStrLn "ContT above streamly: Enter one char per line: "
268 i <- lift $ S.fromFoldable [1..2 :: Int]
269 liftIO $ putStrLn $ "iteration = " <> show i
271 callCC $ \exit -> do
272 r1 <- liftIO getLine
273 _ <- if r1 /= "x"
274 then exit $ Left $ "Expecting x got: " <> r1
275 else return $ Right ()
277 r2 <- liftIO getLine
278 if r2 /= "y"
279 then exit $ Left $ "Expecting y got: " <> r2
280 else return $ Right ()
282mainContAbove :: (IsStream t, MonadIO (t m)) => ContT r (t m) ()
283mainContAbove = do
284 r <- getSequenceContAbove
285 case r of
286 Right _ -> liftIO $ putStrLn "Bingo"
287 Left s -> liftIO $ putStrLn s
289-------------------------------------------------------------------------------
290-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
291-- ContT) with Streamly
292-------------------------------------------------------------------------------
294main :: IO ()
295main = do
296 mainMaybeBelow
297 S.drain $ runMaybeT mainMaybeAbove
298 runContT (S.drain mainContBelow) return
299 S.drain (runContT mainContAbove return)
300 mainEitherBelow
301 S.drain (runExceptT mainEitherAbove)
302 mainMonadThrow
303 mainEitherAsyncBelow