git.iko.soy/streamly
on master help sign in
cleanup Monoid instance
63f965aHarendra Kumar
src/Asyncly/AsyncT.hs+10−15
compare with master
unifiedsplit
@@ -102,6 +102,14 @@ type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)
102-- Monad
102-- Monad
103------------------------------------------------------------------------------
103------------------------------------------------------------------------------
104
104
105+-- | Appends the results of two AsyncT computations in order.
106+instance Monad m => Monoid (AsyncT m a) where
107+ mempty = AsyncT $ \_ stp _ -> stp
108+ mappend (AsyncT m1) m2 = AsyncT $ \ctx stp yld ->
109+ m1 ctx ((runAsyncT m2) ctx stp yld) $ \a c r ->
110+ let yield x = yld a c (Just x)
111+ in maybe (yield m2) (\rx -> yield $ mappend rx m2) r
112+
105-- We do not use bind for parallelism. That is, we do not start each iteration
113-- We do not use bind for parallelism. That is, we do not start each iteration
106-- of the list in parallel. That will introduce too much uncontrolled
114-- of the list in parallel. That will introduce too much uncontrolled
107-- parallelism. Instead we control parallelism using <|>, it is used for
115-- parallelism. Instead we control parallelism using <|>, it is used for
@@ -114,13 +122,6 @@ type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)
114-- thread or not based on the level of the bind in the tree. Maybe at some
122-- thread or not based on the level of the bind in the tree. Maybe at some
115-- point we shall be able to do that?
123-- point we shall be able to do that?
116
124
117−-- XXX make this (<>)
118−serially :: AsyncT m a -> AsyncT m a -> AsyncT m a
119−serially (AsyncT m1) m2 = AsyncT $ \ctx stp yld ->
120− m1 ctx ((runAsyncT m2) ctx stp yld) $ \a c r ->
121− let yield x = yld a c (Just x)
122− in maybe (yield m2) (\rx -> yield $ serially rx m2) r
123−
124instance Monad m => Monad (AsyncT m) where
125instance Monad m => Monad (AsyncT m) where
125 return a = AsyncT $ \ctx _ yld -> yld a ctx Nothing
126 return a = AsyncT $ \ctx _ yld -> yld a ctx Nothing
126
127
@@ -130,7 +131,7 @@ instance Monad m => Monad (AsyncT m) where
130 m Nothing stp $ \a _ r ->
131 m Nothing stp $ \a _ r ->
131 let run x = (runAsyncT x) Nothing stp yld
132 let run x = (runAsyncT x) Nothing stp yld
132 next = f a
133 next = f a
133− in maybe (run next) (\rx -> run $ serially next (rx >>= f)) r
134+ in maybe (run next) (\rx -> run $ next <> (rx >>= f)) r
134
135
135------------------------------------------------------------------------------
136------------------------------------------------------------------------------
136-- Functor
137-- Functor
@@ -299,12 +300,6 @@ instance MonadAsync m => MonadPlus (AsyncT m) where
299 mzero = empty
300 mzero = empty
300 mplus = (<|>)
301 mplus = (<|>)
301
302
302−-- XXX Move it in the beginning
303−-- | Appends the results of two AsyncT computations in order.
304−instance MonadAsync m => Monoid (AsyncT m a) where
305− mempty = empty
306− mappend x y = serially x y
307−
308------------------------------------------------------------------------------
303------------------------------------------------------------------------------
309-- Num
304-- Num
310------------------------------------------------------------------------------
305------------------------------------------------------------------------------
@@ -363,7 +358,7 @@ instance MonadThrow m => MonadThrow (AsyncT m) where
363-- MonadRecorder
358-- MonadRecorder
364------------------------------------------------------------------------------
359------------------------------------------------------------------------------
365
360
366−instance (Monad m, MonadRecorder m) => MonadRecorder (AsyncT m) where
361+instance MonadRecorder m => MonadRecorder (AsyncT m) where
367 getJournal = lift getJournal
362 getJournal = lift getJournal
368 putJournal = lift . putJournal
363 putJournal = lift . putJournal
369 play = lift . play
364 play = lift . play
test/Main.hs+2−2
@@ -18,14 +18,14 @@ main = hspec $ do
18 runAsyncly (liftIO $ putStrLn "hello") `shouldReturn` ()
18 runAsyncly (liftIO $ putStrLn "hello") `shouldReturn` ()
19 it "Captures a return value using toList" $
19 it "Captures a return value using toList" $
20 toList (return 0) `shouldReturn` ([0] :: [Int])
20 toList (return 0) `shouldReturn` ([0] :: [Int])
21+ it "Monoid composition" $
22+ toList (return 0 <> return 1) `shouldReturn` ([0, 1] :: [Int])
21 it "simple runAsyncly and 'then' with IO" $
23 it "simple runAsyncly and 'then' with IO" $
22 runAsyncly (liftIO (putStrLn "hello") >> liftIO (putStrLn "world")) `shouldReturn` ()
24 runAsyncly (liftIO (putStrLn "hello") >> liftIO (putStrLn "world")) `shouldReturn` ()
23 it "Then and toList" $
25 it "Then and toList" $
24 toList (return 1 >> return 2) `shouldReturn` ([2] :: [Int])
26 toList (return 1 >> return 2) `shouldReturn` ([2] :: [Int])
25 it "Bind and toList" $
27 it "Bind and toList" $
26 toList (do x <- return 1; y <- return 2; return (x + y)) `shouldReturn` ([3] :: [Int])
28 toList (do x <- return 1; y <- return 2; return (x + y)) `shouldReturn` ([3] :: [Int])
27− it "Monoid composition" $
28− toList (return 0 <> return 1) `shouldReturn` ([0, 1] :: [Int])
29 it "Alternative composition" $
29 it "Alternative composition" $
30 ((toList $ (return 0 <|> return 1)) >>= return . sort) `shouldReturn` ([0, 1] :: [Int])
30 ((toList $ (return 0 <|> return 1)) >>= return . sort) `shouldReturn` ([0, 1] :: [Int])
31 it "Alternative composition - each" $
31 it "Alternative composition - each" $