Merge pull request #645 from scshunt/free-zoom

Free Zoom

src/Control/Lens/Internal/Zoom.hs

@@ -24,6 +24,7 @@ module Control.Lens.Internal.Zoom
   , FocusingOn(..)
   , FocusingMay(..), May(..)
   , FocusingErr(..), Err(..)
+  , FocusingFree(..)
   -- * Magnify
   , Effect(..)
   , EffectRWS(..)
@@ -33,6 +34,7 @@ import Control.Applicative
 import Control.Category
 import Control.Comonad
 import Control.Monad.Reader as Reader
+import Control.Monad.Trans.Free
 import Data.Functor.Bind
 import Data.Functor.Contravariant
 import Data.Semigroup
@@ -222,6 +224,28 @@ instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where
   FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka)
   {-# INLINE (<*>) #-}
 
+------------------------------------------------------------------------------
+-- FocusingFree
+------------------------------------------------------------------------------
+
+-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into
+-- 'Control.Monad.Trans.FreeT'
+newtype FocusingFree f m k s a = FocusingFree { unfocusingFree :: k (FreeF f s (FreeT f m s)) a }
+
+instance Functor (k (FreeF f s (FreeT f m s))) => Functor (FocusingFree f m k s) where
+  fmap f (FocusingFree as) = FocusingFree (fmap f as)
+  {-# INLINE fmap #-}
+
+instance Apply (k (FreeF f s (FreeT f m s))) => Apply (FocusingFree f m k s) where
+  FocusingFree kf <.> FocusingFree ka = FocusingFree (kf <.> ka)
+  {-# INLINE (<.>) #-}
+
+instance Applicative (k (FreeF f s (FreeT f m s))) => Applicative (FocusingFree f m k s) where
+  pure = FocusingFree . pure
+  {-# INLINE pure #-}
+  FocusingFree kf <*> FocusingFree ka = FocusingFree (kf <*> ka)
+  {-# INLINE (<*>) #-}
+
 -----------------------------------------------------------------------------
 --- Effect
 -------------------------------------------------------------------------------

src/Control/Lens/Zoom.hs

@@ -52,6 +52,7 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.List
 import Control.Monad.Trans.Identity
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Free
 import Data.Monoid
 import Data.Profunctor.Unsafe
 import Prelude
@@ -91,6 +92,7 @@ type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m)
 type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m)
 type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m)
 type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m)
+type instance Zoomed (FreeT f m) = FocusingFree f m (Zoomed m)
 
 ------------------------------------------------------------------------------
 -- Magnified
@@ -111,7 +113,7 @@ type instance Magnified (IdentityT m) = Magnified m
 -- | This class allows us to use 'zoom' in, changing the 'State' supplied by
 -- many different 'Control.Monad.Monad' transformers, potentially quite
 -- deep in a 'Monad' transformer stack.
-class (Zoomed m ~ Zoomed n, MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where
+class (MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where
   -- | Run a monadic action in a larger 'State' than it was defined in,
   -- using a 'Lens'' or 'Control.Lens.Traversal.Traversal''.
   --
@@ -198,6 +200,9 @@ instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where
   zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runExceptT
   {-# INLINE zoom #-}
 
+instance (Functor f, Zoom m n s t) => Zoom (FreeT f m) (FreeT f n) s t where
+  zoom l = FreeT . fmap (fmap $ zoom l) . zoom (\afb -> unfocusingFree #. l (FocusingFree #. afb)) . runFreeT
+
 ------------------------------------------------------------------------------
 -- Magnify
 ------------------------------------------------------------------------------