git.iko.soy/streamly
on beabbcc help sign in
streamly/examples/ControlFlow.hs
308 lines 10 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE ScopedTypeVariables #-}
5-------------------------------------------------------------------------------
6-- Combining control flow manipulating monad transformers (MaybeT, exceptT,
7-- ContT) with Streamly
8-------------------------------------------------------------------------------
9--
10-- Streamly streams are non-determinism (nested looping) monads. We can use a
11-- control flow monad on top or streamly on top depending on whether we want to
12-- superimpose control flow manipulation on top of non-deterministic
13-- composition or vice-versa.
14--
15-- This file provides an example where we enter a sequence of characters "x",
16-- and "y" on separate lines, on the command line. When any other sequence is
17-- entered the control flow short circuits at the first non-matching char and
19-- exits.
21#if !(MIN_VERSION_base(4,11,0))
22import Data.Semigroup (Semigroup(..))
23#endif
24import Control.Concurrent (threadDelay)
25import Control.Exception (catch, SomeException)
26import Control.Monad
27import Control.Monad.Catch (MonadThrow, throwM, Exception)
28import Control.Monad.IO.Class
29import Control.Monad.Trans.Class
30import Control.Monad.Trans.Maybe
31import Control.Monad.Trans.Except
32import Control.Monad.Trans.Cont
33import Streamly.Prelude
34import qualified Streamly.Prelude as S
36-------------------------------------------------------------------------------
37-- Using MaybeT below streamly
38-------------------------------------------------------------------------------
39--
40-- When streamly is on top MaybeT would terminate all iterations of
41-- non-determinism.
42--
43getSequenceMaybeBelow
44 :: ( IsStream t
45 , Monad m
46 , MonadTrans t
47 , MonadIO (t (MaybeT m))
48 )
49 => t (MaybeT m) ()
50getSequenceMaybeBelow = do
51 liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "
53 i <- S.fromFoldable [1..2 :: Int]
54 liftIO $ putStrLn $ "iteration = " <> show i
56 r1 <- liftIO getLine
57 when (r1 /= "x") $ lift mzero
59 r2 <- liftIO getLine
60 when (r2 /= "y") $ lift mzero
62mainMaybeBelow :: IO ()
63mainMaybeBelow = do
64 r <- runMaybeT (S.drain getSequenceMaybeBelow)
65 case r of
66 Just _ -> putStrLn "Bingo"
67 Nothing -> putStrLn "Wrong"
69-------------------------------------------------------------------------------
70-- Using MaybeT above streamly
71-------------------------------------------------------------------------------
72--
73-- When MaybeT is on top a Nothing would terminate only the current iteration
74-- of non-determinism below.
75--
76-- Note that this is redundant configuration as the same behavior can be
77-- achieved with just streamly, using mzero.
78--
79getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
80getSequenceMaybeAbove = do
81 liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "
83 i <- lift $ S.fromFoldable [1..2 :: Int]
84 liftIO $ putStrLn $ "iteration = " <> show i
86 r1 <- liftIO getLine
87 when (r1 /= "x") mzero
89 r2 <- liftIO getLine
90 when (r2 /= "y") mzero
92mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
93mainMaybeAbove = do
94 getSequenceMaybeAbove
95 liftIO $ putStrLn "Bingo"
97-------------------------------------------------------------------------------
98-- Using ExceptT below streamly
99-------------------------------------------------------------------------------
100--
101-- XXX need to have a specialized liftCatch to lift catchE
102--
103-- Note that throwE would terminate all iterations of non-determinism
104-- altogether.
105getSequenceEitherBelow
106 :: ( IsStream t
107 , MonadTrans t
108 , Monad m
109 , MonadIO (t (ExceptT String m))
110 )
111 => t (ExceptT String m) ()
112getSequenceEitherBelow = do
113 liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "
115 i <- S.fromFoldable [1..2 :: Int]
116 liftIO $ putStrLn $ "iteration = " <> show i
118 r1 <- liftIO getLine
119 when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " <> r1
121 r2 <- liftIO getLine
122 when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " <> r2
124mainEitherBelow :: IO ()
125mainEitherBelow = do
126 -- XXX Cannot lift catchE
127 r <- runExceptT (S.drain getSequenceEitherBelow)
128 case r of
129 Right _ -> liftIO $ putStrLn "Bingo"
130 Left s -> liftIO $ putStrLn s
132-------------------------------------------------------------------------------
133-- Using ExceptT below concurrent streamly
134-------------------------------------------------------------------------------
135--
136-- XXX does not work correctly yet
137--
138getSequenceEitherAsyncBelow
139 :: ( IsStream t
140 , MonadTrans t
141 , MonadIO 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 (S.drain $ 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, 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, MonadIO (t m)) => 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, 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, 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, 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