From 1ff2e64428b86a60ee955b9d267764a0707cecd1 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Fri, 8 Sep 2017 13:45:41 -0400
Subject: [PATCH 1/2] Add copy operations

These are the `FreeT` editions of a generalization of
`streaming:Streaming.Prelude.copy`.

```haskell
copy :: (Applicative m, Comonad f) => FreeT f m r -> FreeT f (FreeT f m) r
copy' :: (Applicative m, Extend f) => FreeT f m r -> FreeT f (FreeT f m) r
```

Cale Gibbard suspects `copy` might make some sensible comonadish thing
along with

```haskell
extrude :: (Monad m, Comonad f) => FreeT f m r -> m r
extrude = iterT extract
```
---
 src/Control/Monad/Trans/Free.hs | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs
index 19cf606..56429d0 100644
--- a/src/Control/Monad/Trans/Free.hs
+++ b/src/Control/Monad/Trans/Free.hs
@@ -43,6 +43,8 @@ module Control.Monad.Trans.Free
   , intersperseT
   , intercalateT
   , retractT
+  , copy
+  , copy'
   -- * Operations of free monad
   , retract
   , iter
@@ -52,6 +54,7 @@ module Control.Monad.Trans.Free
   ) where
 
 import Control.Applicative
+import Control.Comonad (Comonad (..))
 import Control.Monad (liftM, MonadPlus(..), ap, join)
 import Control.Monad.Base (MonadBase(..))
 import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
@@ -66,6 +69,7 @@ import Control.Monad.Error.Class
 import Control.Monad.Cont.Class
 import Data.Functor.Bind hiding (join)
 import Data.Functor.Classes.Compat
+import Data.Functor.Extend (Extend (..))
 import Data.Monoid
 import Data.Functor.Identity
 import Data.Traversable
@@ -403,6 +407,18 @@ iterTM f (FreeT m) = do
         Pure x -> return x
         Free y -> f y
 
+copy :: (Applicative m, Comonad f) => FreeT f m r -> FreeT f (FreeT f m) r
+copy (FreeT t) = FreeT $ FreeT $ flip fmap t $
+  \str -> case str of
+    Pure r -> Pure (Pure r)
+    Free f -> Free $ extend (FreeT . pure . Pure . Free) (fmap copy f)
+
+copy' :: (Applicative m, Extend f) => FreeT f m r -> FreeT f (FreeT f m) r
+copy' (FreeT t) = FreeT $ FreeT $ flip fmap t $
+  \str -> case str of
+    Pure r -> Pure (Pure r)
+    Free f -> Free $ extended (FreeT . pure . Pure . Free) (fmap copy' f)
+
 instance (Foldable m, Foldable f) => Foldable (FreeT f m) where
   foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m
 

From 34c8088cc5c2d13b87f475649b3835b2dff9add3 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Fri, 8 Sep 2017 15:36:04 -0400
Subject: [PATCH 2/2] Add more general version

---
 src/Control/Monad/Trans/Free.hs | 20 ++++++++++++--------
 1 file changed, 12 insertions(+), 8 deletions(-)

diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs
index 56429d0..1cc2b64 100644
--- a/src/Control/Monad/Trans/Free.hs
+++ b/src/Control/Monad/Trans/Free.hs
@@ -45,6 +45,7 @@ module Control.Monad.Trans.Free
   , retractT
   , copy
   , copy'
+  , expand
   -- * Operations of free monad
   , retract
   , iter
@@ -407,17 +408,20 @@ iterTM f (FreeT m) = do
         Pure x -> return x
         Free y -> f y
 
+expand :: (Applicative m, Functor f)
+        => (forall a b. (g a -> b) -> f a -> h b)
+        -> FreeT f m r -> FreeT g (FreeT h m) r
+expand g = loop where
+  loop (FreeT t) = FreeT $ FreeT $ flip fmap t $
+    \str -> case str of
+      Pure r -> Pure (Pure r)
+      Free f -> Free $ g (FreeT . pure . Pure . Free) (fmap loop f)
+
 copy :: (Applicative m, Comonad f) => FreeT f m r -> FreeT f (FreeT f m) r
-copy (FreeT t) = FreeT $ FreeT $ flip fmap t $
-  \str -> case str of
-    Pure r -> Pure (Pure r)
-    Free f -> Free $ extend (FreeT . pure . Pure . Free) (fmap copy f)
+copy = expand extend
 
 copy' :: (Applicative m, Extend f) => FreeT f m r -> FreeT f (FreeT f m) r
-copy' (FreeT t) = FreeT $ FreeT $ flip fmap t $
-  \str -> case str of
-    Pure r -> Pure (Pure r)
-    Free f -> Free $ extended (FreeT . pure . Pure . Free) (fmap copy' f)
+copy' = expand extended
 
 instance (Foldable m, Foldable f) => Foldable (FreeT f m) where
   foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m