module Control.Lens.Internal.Zoom
(
Zoomed
, Focusing(..)
, FocusingWith(..)
, FocusingPlus(..)
, FocusingOn(..)
, FocusingMay(..), May(..)
, FocusingErr(..), Err(..)
, Magnified
, Effect(..)
, EffectRWS(..)
) where
import Control.Applicative
import Control.Category
import Control.Comonad
import Control.Monad.Reader as Reader
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Control.Monad.Trans.RWS.Lazy as Lazy
import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Error
import Control.Monad.Trans.Except
import Control.Monad.Trans.List
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Data.Functor.Bind
import Data.Functor.Contravariant
import Data.Semigroup
import Prelude hiding ((.),id)
type family Zoomed (m :: * -> *) :: * -> * -> *
type instance Zoomed (Strict.StateT s z) = Focusing z
type instance Zoomed (Lazy.StateT s z) = Focusing z
type instance Zoomed (ReaderT e m) = Zoomed m
type instance Zoomed (IdentityT m) = Zoomed m
type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z
type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z
type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m)
type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m)
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)
newtype Focusing m s a = Focusing { unfocusing :: m (s, a) }
instance Monad m => Functor (Focusing m s) where
fmap f (Focusing m) = Focusing $ do
(s, a) <- m
return (s, f a)
instance (Monad m, Semigroup s) => Apply (Focusing m s) where
Focusing mf <.> Focusing ma = Focusing $ do
(s, f) <- mf
(s', a) <- ma
return (s <> s', f a)
instance (Monad m, Monoid s) => Applicative (Focusing m s) where
pure a = Focusing (return (mempty, a))
Focusing mf <*> Focusing ma = Focusing $ do
(s, f) <- mf
(s', a) <- ma
return (mappend s s', f a)
newtype FocusingWith w m s a = FocusingWith { unfocusingWith :: m (s, a, w) }
instance Monad m => Functor (FocusingWith w m s) where
fmap f (FocusingWith m) = FocusingWith $ do
(s, a, w) <- m
return (s, f a, w)
instance (Monad m, Semigroup s, Semigroup w) => Apply (FocusingWith w m s) where
FocusingWith mf <.> FocusingWith ma = FocusingWith $ do
(s, f, w) <- mf
(s', a, w') <- ma
return (s <> s', f a, w <> w')
instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where
pure a = FocusingWith (return (mempty, a, mempty))
FocusingWith mf <*> FocusingWith ma = FocusingWith $ do
(s, f, w) <- mf
(s', a, w') <- ma
return (mappend s s', f a, mappend w w')
newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a }
instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where
fmap f (FocusingPlus as) = FocusingPlus (fmap f as)
instance Apply (k (s, w)) => Apply (FocusingPlus w k s) where
FocusingPlus kf <.> FocusingPlus ka = FocusingPlus (kf <.> ka)
instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where
pure = FocusingPlus . pure
FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka)
newtype FocusingOn f k s a = FocusingOn { unfocusingOn :: k (f s) a }
instance Functor (k (f s)) => Functor (FocusingOn f k s) where
fmap f (FocusingOn as) = FocusingOn (fmap f as)
instance Apply (k (f s)) => Apply (FocusingOn f k s) where
FocusingOn kf <.> FocusingOn ka = FocusingOn (kf <.> ka)
instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where
pure = FocusingOn . pure
FocusingOn kf <*> FocusingOn ka = FocusingOn (kf <*> ka)
newtype May a = May { getMay :: Maybe a }
instance Semigroup a => Semigroup (May a) where
May Nothing <> _ = May Nothing
_ <> May Nothing = May Nothing
May (Just a) <> May (Just b) = May (Just (a <> b))
instance Monoid a => Monoid (May a) where
mempty = May (Just mempty)
May Nothing `mappend` _ = May Nothing
_ `mappend` May Nothing = May Nothing
May (Just a) `mappend` May (Just b) = May (Just (mappend a b))
newtype FocusingMay k s a = FocusingMay { unfocusingMay :: k (May s) a }
instance Functor (k (May s)) => Functor (FocusingMay k s) where
fmap f (FocusingMay as) = FocusingMay (fmap f as)
instance Apply (k (May s)) => Apply (FocusingMay k s) where
FocusingMay kf <.> FocusingMay ka = FocusingMay (kf <.> ka)
instance Applicative (k (May s)) => Applicative (FocusingMay k s) where
pure = FocusingMay . pure
FocusingMay kf <*> FocusingMay ka = FocusingMay (kf <*> ka)
newtype Err e a = Err { getErr :: Either e a }
instance Semigroup a => Semigroup (Err e a) where
Err (Left e) <> _ = Err (Left e)
_ <> Err (Left e) = Err (Left e)
Err (Right a) <> Err (Right b) = Err (Right (a <> b))
instance Monoid a => Monoid (Err e a) where
mempty = Err (Right mempty)
Err (Left e) `mappend` _ = Err (Left e)
_ `mappend` Err (Left e) = Err (Left e)
Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b))
newtype FocusingErr e k s a = FocusingErr { unfocusingErr :: k (Err e s) a }
instance Functor (k (Err e s)) => Functor (FocusingErr e k s) where
fmap f (FocusingErr as) = FocusingErr (fmap f as)
instance Apply (k (Err e s)) => Apply (FocusingErr e k s) where
FocusingErr kf <.> FocusingErr ka = FocusingErr (kf <.> ka)
instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where
pure = FocusingErr . pure
FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka)
type family Magnified (m :: * -> *) :: * -> * -> *
type instance Magnified (ReaderT b m) = Effect m
type instance Magnified ((->)b) = Const
type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m
type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m
type instance Magnified (IdentityT m) = Magnified m
newtype Effect m r a = Effect { getEffect :: m r }
instance Functor (Effect m r) where
fmap _ (Effect m) = Effect m
instance Contravariant (Effect m r) where
contramap _ (Effect m) = Effect m
instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where
Effect ma <> Effect mb = Effect (liftF2 (<>) ma mb)
instance (Monad m, Monoid r) => Monoid (Effect m r a) where
mempty = Effect (return mempty)
Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb)
instance (Apply m, Semigroup r) => Apply (Effect m r) where
Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb)
instance (Monad m, Monoid r) => Applicative (Effect m r) where
pure _ = Effect (return mempty)
Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb)
newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) }
instance Functor (EffectRWS w st m s) where
fmap _ (EffectRWS m) = EffectRWS m
instance (Semigroup s, Semigroup w, Bind m) => Apply (EffectRWS w st m s) where
EffectRWS m <.> EffectRWS n = EffectRWS $ \st -> m st >>- \ (s,t,w) -> fmap (\(s',u,w') -> (s <> s', u, w <> w')) (n t)
instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where
pure _ = EffectRWS $ \st -> return (mempty, st, mempty)
EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w')
instance Contravariant (EffectRWS w st m s) where
contramap _ (EffectRWS m) = EffectRWS m