module Lens.Family.State.Zoom where

import Control.Monad (liftM)

newtype Zooming m c a = Zooming { Zooming m c a -> m (c, a)
unZooming :: m (c, a) }

instance Monad m => Functor (Zooming m c) where
  fmap :: (a -> b) -> Zooming m c a -> Zooming m c b
fmap a -> b
f (Zooming m (c, a)
m) = m (c, b) -> Zooming m c b
forall (m :: * -> *) c a. m (c, a) -> Zooming m c a
Zooming (((c, a) -> (c, b)) -> m (c, a) -> m (c, b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> b) -> (c, a) -> (c, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (c, a)
m)

instance (Monoid c, Monad m) => Applicative (Zooming m c) where
  pure :: a -> Zooming m c a
pure a
a = m (c, a) -> Zooming m c a
forall (m :: * -> *) c a. m (c, a) -> Zooming m c a
Zooming ((c, a) -> m (c, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (c
forall a. Monoid a => a
mempty, a
a))
  Zooming m (c, a -> b)
f <*> :: Zooming m c (a -> b) -> Zooming m c a -> Zooming m c b
<*> Zooming m (c, a)
x = m (c, b) -> Zooming m c b
forall (m :: * -> *) c a. m (c, a) -> Zooming m c a
Zooming (m (c, b) -> Zooming m c b) -> m (c, b) -> Zooming m c b
forall a b. (a -> b) -> a -> b
$ do
    (c
a, a -> b
f') <- m (c, a -> b)
f
    (c
b, a
x') <- m (c, a)
x
    (c, b) -> m (c, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (c
a c -> c -> c
forall a. Semigroup a => a -> a -> a
<> c
b, a -> b
f' a
x')