From 251b51b415446e19f06b26ed9b8d305a3d057dae Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Sat, 26 Aug 2017 15:44:57 -0400
Subject: [PATCH 1/3] Add differently-constrained maps and mapped

Sometimes, the target functor of `maps` or `mapped` offers
a more efficient `fmap` than the source functor. Add versions
of `maps`, `mapped`, and `mapsM` that use that one instead.
---
 src/Streaming.hs          |  3 +++
 src/Streaming/Internal.hs | 55 ++++++++++++++++++++++++++++++++++++---
 src/Streaming/Prelude.hs  | 10 +++++++
 3 files changed, 65 insertions(+), 3 deletions(-)

diff --git a/src/Streaming.hs b/src/Streaming.hs
index cc8966a..20b9a40 100644
--- a/src/Streaming.hs
+++ b/src/Streaming.hs
@@ -19,8 +19,11 @@ module Streaming
 
    -- * Transforming streams
    maps,
+   maps2,
    mapsM,
+   mapsM2,
    mapped,
+   mapped2,
    distribute,
    groups,
 
diff --git a/src/Streaming/Internal.hs b/src/Streaming/Internal.hs
index 3b4515d..4d9f25b 100644
--- a/src/Streaming/Internal.hs
+++ b/src/Streaming/Internal.hs
@@ -34,6 +34,8 @@ module Streaming.Internal (
     -- * Transforming streams
     , maps
     , mapsM
+    , maps2
+    , mapsM2
     , decompose
     , mapsM_
     , run
@@ -489,8 +491,8 @@ maps phi = loop where
 {-# INLINABLE maps #-}
 
 
-{- | Map layers of one functor to another with a transformation involving the base monad
-     @maps@ is more fundamental than @mapsM@, which is best understood as a convenience
+{- | Map layers of one functor to another with a transformation involving the base monad.
+     'maps' is more fundamental than @mapsM@, which is best understood as a convenience
      for effecting this frequent composition:
 
 > mapsM phi = decompose . maps (Compose . phi)
@@ -507,6 +509,53 @@ mapsM phi = loop where
     Step f    -> Effect (liftM Step (phi (fmap loop f)))
 {-# INLINABLE mapsM #-}
 
+{- | Map layers of one functor to another with a transformation. Compare
+     hoist, which has a similar effect on the 'monadic' parameter.
+
+> maps2 id = id
+> maps2 f . maps2 g = maps2 (f . g)
+> maps2 f = maps2 f
+
+
+     @maps2@ is essentially the same as 'maps', but it imposes a 'Functor' constraint on
+     its target functor rather than its source functor. It should be preferred if 'fmap'
+     is cheaper for the target functor than for the source functor.
+-}
+maps2 :: forall m f g r. (Monad m, Functor g)
+      => (forall x. f x -> g x)
+      -> Stream f m r -> Stream g m r
+maps2 phi = loop where
+  loop :: Stream f m r -> Stream g m r
+  loop stream = case stream of
+    Return r -> Return r
+    Effect m -> Effect (liftM loop m)
+    Step f -> Step $ fmap loop $ phi f
+{-# INLINABLE maps2 #-}
+
+{- | Map layers of one functor to another with a transformation involving the base monad.
+     @mapsM2@ is essentially the same as 'mapsM', but it imposes a 'Functor' constraint on
+     its target functor rather than its source functor. It should be preferred if 'fmap'
+     is cheaper for the target functor than for the source functor.
+
+     @maps2@ is more fundamental than @mapsM2@, which is best understood as a convenience
+     for effecting this frequent composition:
+
+> mapsM2 phi = decompose . maps2 (Compose . phi)
+
+     The streaming prelude exports the same function under the better name @mapped2@,
+     which overlaps with the lens libraries.
+
+-}
+mapsM2 :: forall m f g r. (Monad m, Functor g)
+       => (forall x. f x -> m (g x))
+       -> Stream f m r -> Stream g m r
+mapsM2 phi = loop where
+  loop :: Stream f m r -> Stream g m r
+  loop stream = case stream of
+    Return r -> Return r
+    Effect m -> Effect (liftM loop m)
+    Step f -> Effect $ liftM (Step . fmap loop) (phi f)
+{-# INLINABLE mapsM2 #-}
 
 {-| Rearrange a succession of layers of the form @Compose m (f x)@.
 
@@ -1201,4 +1250,4 @@ cutoff = loop where
       e <- lift $ inspect str
       case e of
         Left r -> return (Just r)
-        Right (frest) -> Step $ fmap (loop (n-1)) frest
\ No newline at end of file
+        Right (frest) -> Step $ fmap (loop (n-1)) frest
diff --git a/src/Streaming/Prelude.hs b/src/Streaming/Prelude.hs
index 4e30c30..893176e 100644
--- a/src/Streaming/Prelude.hs
+++ b/src/Streaming/Prelude.hs
@@ -95,7 +95,9 @@ module Streaming.Prelude (
     , map
     , mapM
     , maps
+    , maps2
     , mapped
+    , mapped2
     , for
     , with
     , subst
@@ -1351,6 +1353,14 @@ mapped :: (Monad m, Functor f) => (forall x . f x -> m (g x)) -> Stream f m r ->
 mapped = mapsM
 {-#INLINE mapped #-}
 
+{-| A version of 'mapped' that imposes a 'Functor' constraint on the target functor rather
+    than the source functor. This version should be preferred if 'fmap' on the target
+    functor is cheaper.
+
+-}
+mapped2 :: (Monad m, Functor g) => (forall x . f x -> m (g x)) -> Stream f m r -> Stream g m r
+mapped2 = mapsM2
+{-# INLINE mapped2 #-}
 
 {-| Fold streamed items into their monoidal sum
 

From 642aeb716e1a554cac6e6d374dd9d2cbd18920f5 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Tue, 12 Sep 2017 19:41:12 -0400
Subject: [PATCH 2/3] Add hoists

Add explicitly "unsafe" `hoistUnexposed` and `hoistUnexposed2`.
Add "safe" `hoistUnexposed`.
---
 src/Streaming.hs          |  1 +
 src/Streaming/Internal.hs | 34 ++++++++++++++++++++++++++++++++--
 2 files changed, 33 insertions(+), 2 deletions(-)

diff --git a/src/Streaming.hs b/src/Streaming.hs
index 20b9a40..38a6f2d 100644
--- a/src/Streaming.hs
+++ b/src/Streaming.hs
@@ -24,6 +24,7 @@ module Streaming
    mapsM2,
    mapped,
    mapped2,
+   hoistUnexposed,
    distribute,
    groups,
 
diff --git a/src/Streaming/Internal.hs b/src/Streaming/Internal.hs
index 4d9f25b..52b39c6 100644
--- a/src/Streaming/Internal.hs
+++ b/src/Streaming/Internal.hs
@@ -36,6 +36,7 @@ module Streaming.Internal (
     , mapsM
     , maps2
     , mapsM2
+    , hoistUnexposed
     , decompose
     , mapsM_
     , run
@@ -72,6 +73,7 @@ module Streaming.Internal (
     -- *  For use in implementation
     , unexposed
     , hoistExposed
+    , hoistExposed2
     , mapsExposed
     , mapsMExposed
     , destroyExposed
@@ -242,6 +244,7 @@ instance Functor f => MFunctor (Stream f) where
       Step f    -> Step (fmap loop f)
   {-# INLINABLE hoist #-}  
 
+
 instance Functor f => MMonad (Stream f) where
   embed phi = loop where
     loop stream = case stream of
@@ -776,13 +779,40 @@ replicates n f = splitsAt n (repeats f) >> return ()
 cycles :: (Monad m, Functor f) =>  Stream f m () -> Stream f m r
 cycles = forever
 
+-- | A version of 'hoist' that works properly even when its
+-- argument is not a monad morphism.
+--
+-- > hoistUnexposed = hoist . unexposed
+hoistUnexposed :: (Monad m, Functor f) => (forall a. m a -> n a) -> Stream f m r -> Stream f n r
+hoistUnexposed trans = Effect . loop where
+  loop stream = trans $ do
+    rs <- inspect stream
+    case rs of
+      Left r -> return (Return r)
+      Right f -> return (Step (fmap (Effect . loop) f))
+{-# INLINABLE hoistUnexposed #-}
 
-
+-- | The same as 'hoist', but explicitly named to indicate that it
+-- is not entirely safe. In particular, its argument must be a monad
+-- morphism.
+hoistExposed :: (Functor m, Functor f) => (forall a. m a -> n a) -> Stream f m a -> Stream f n a
 hoistExposed trans = loop where
   loop stream = case stream of
     Return r  -> Return r
-    Effect m   -> Effect (trans (liftM loop m))
+    Effect m   -> Effect (trans (fmap loop m))
     Step f    -> Step (fmap loop f)
+{-# INLINABLE hoistExposed #-}
+
+-- | The same as 'hoistExposed', but with a 'Functor' constraint on
+-- the target rather than the source. This must be used only with
+-- a monad morphism.
+hoistExposed2 :: (Functor n, Functor f) => (forall a. m a -> n a) -> Stream f m a -> Stream f n a
+hoistExposed2 trans = loop where
+  loop stream = case stream of
+    Return r -> Return r
+    Effect m -> Effect (fmap loop (trans m))
+    Step f -> Step (fmap loop f)
+{-# INLINABLE hoistExposed2 #-}
 
 mapsExposed :: (Monad m, Functor f)
      => (forall x . f x -> g x) -> Stream f m r -> Stream g m r

From 312fa1c25428597089d71c906889b51df2dc39d8 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Wed, 13 Sep 2017 02:42:04 -0400
Subject: [PATCH 3/3] Improve hoistUnexposed

---
 src/Streaming/Internal.hs | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/src/Streaming/Internal.hs b/src/Streaming/Internal.hs
index 52b39c6..f357a55 100644
--- a/src/Streaming/Internal.hs
+++ b/src/Streaming/Internal.hs
@@ -779,19 +779,25 @@ replicates n f = splitsAt n (repeats f) >> return ()
 cycles :: (Monad m, Functor f) =>  Stream f m () -> Stream f m r
 cycles = forever
 
--- | A version of 'hoist' that works properly even when its
+-- | A less-efficient version of 'hoist' that works properly even when its
 -- argument is not a monad morphism.
 --
 -- > hoistUnexposed = hoist . unexposed
-hoistUnexposed :: (Monad m, Functor f) => (forall a. m a -> n a) -> Stream f m r -> Stream f n r
-hoistUnexposed trans = Effect . loop where
-  loop stream = trans $ do
-    rs <- inspect stream
-    case rs of
-      Left r -> return (Return r)
-      Right f -> return (Step (fmap (Effect . loop) f))
+hoistUnexposed :: (Monad m, Functor f)
+               => (forall a. m a -> n a)
+               -> Stream f m r -> Stream f n r
+hoistUnexposed trans = loop where
+  loop = Effect . trans . inspectC (pure . Return) (pure . Step . fmap loop)
 {-# INLINABLE hoistUnexposed #-}
 
+-- A version of 'inspect' that takes explicit continuations.
+inspectC :: Monad m => (r -> m a) -> (f (Stream f m r) -> m a) -> Stream f m r -> m a
+inspectC f g = loop where
+  loop (Return r) = f r
+  loop (Step x) = g x
+  loop (Effect m) = m >>= loop
+{-# INLINE inspectC #-}
+
 -- | The same as 'hoist', but explicitly named to indicate that it
 -- is not entirely safe. In particular, its argument must be a monad
 -- morphism.