From 8e2be01ba9f2c26d09af8c76036a91fa8b2379e1 Mon Sep 17 00:00:00 2001
From: Science! <cporesky@gmail.com>
Date: Tue, 26 Mar 2019 13:27:47 -0400
Subject: [PATCH] added Semigroup and Monoid instances for SourceT

---
 servant/src/Servant/Types/SourceT.hs | 30 ++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

diff --git a/servant/src/Servant/Types/SourceT.hs b/servant/src/Servant/Types/SourceT.hs
index 284be4bf..b3a9db31 100644
--- a/servant/src/Servant/Types/SourceT.hs
+++ b/servant/src/Servant/Types/SourceT.hs
@@ -89,6 +89,20 @@ instance MFunctor SourceT where
     hoist f (SourceT m) = SourceT $ \k -> k $
         Effect $ f $ fmap (hoist f) $ m return
 
+-- | >>> source "xy" <> source "z" :: SourceT Identity Char
+-- fromStepT (Effect (Identity (Yield 'x' (Yield 'y' (Yield 'z' Stop)))))
+--
+instance Functor m => Semigroup (SourceT m a) where
+    SourceT withL <> SourceT withR = SourceT $ \ret ->
+        withL $ \l ->
+        withR $ \r ->
+        ret $ l <> r
+
+-- | >>> mempty :: SourceT Maybe Int
+-- fromStepT (Effect (Just Stop))
+instance Functor m => Monoid (SourceT m a) where
+    mempty = fromStepT mempty
+
 -- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink.
 instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where
     arbitrary = fromStepT <$> QC.arbitrary
@@ -150,6 +164,22 @@ instance MFunctor StepT where
         go (Yield x s) = Yield x (go s)
         go (Effect ms) = Effect (f (fmap go ms))
 
+instance Functor m => Semigroup (StepT m a) where
+    Stop      <> r = r
+    Error err <> _ = Error err
+    Skip s    <> r = Skip (s <> r)
+    Yield x s <> r = Yield x (s <> r)
+    Effect ms <> r = Effect ((<> r) <$> ms)
+
+-- | >>> mempty :: StepT [] Int
+-- Stop
+--
+-- >>> mempty :: StepT Identity Int
+-- Stop
+--
+instance Functor m => Monoid (StepT m a) where
+    mempty = Stop
+
 -- | Doesn't generate 'Error' constructors.
 instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where
     arbitrary = QC.sized arb where