{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Profunctor.Optic.Zoom where
import Control.Monad.Reader as Reader
import Control.Monad.State as State
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.RWS.Lazy as Lazy
import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Identity
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Types
infixr 2 `zoom`
type family Zoomed (m :: * -> *) :: * -> * -> *
type instance Zoomed (IdentityT m) = Zoomed m
type instance Zoomed (ReaderT e m) = Zoomed m
type instance Zoomed (Strict.StateT s z) = StateTRep z
type instance Zoomed (Lazy.StateT s z) = StateTRep z
type instance Zoomed (Strict.RWST r w s z) = RWSTRep w z
type instance Zoomed (Lazy.RWST r w s z) = RWSTRep w z
class (MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where
zoom :: Optic' (Star (Zoomed m c)) t s -> m c -> n c
instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where
zoom l (IdentityT m) = IdentityT (zoom l m)
{-# INLINE zoom #-}
instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where
zoom l (ReaderT m) = ReaderT (zoom l . m)
{-# INLINE zoom #-}
instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) s t where
zoom o m = Strict.StateT $ unStateTRep #. (runStar #. o .# Star) (StateTRep #. (Strict.runStateT m))
{-# INLINE zoom #-}
instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) s t where
zoom o m = Lazy.StateT $ unStateTRep #. (runStar #. o .# Star) (StateTRep #. (Lazy.runStateT m))
{-# INLINE zoom #-}
instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) s t where
zoom o m = Strict.RWST $ \r -> unRWSTRep #. (runStar #. o .# Star) (RWSTRep #. (Strict.runRWST m r))
{-# INLINE zoom #-}
instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) s t where
zoom o m = Lazy.RWST $ \r -> unRWSTRep #. (runStar #. o .# Star) (RWSTRep #. (Lazy.runRWST m r))
{-# INLINE zoom #-}
newtype StateTRep m s a = StateTRep { unStateTRep :: m (s, a) }
instance Monad m => Functor (StateTRep m s) where
fmap f (StateTRep m) = StateTRep $ do
(s, a) <- m
return (s, f a)
{-# INLINE fmap #-}
instance (Monad m, Semigroup s) => Apply (StateTRep m s) where
StateTRep mf <.> StateTRep ma = StateTRep $ do
(s, f) <- mf
(s', a) <- ma
return (s <> s', f a)
{-# INLINE (<.>) #-}
instance (Monad m, Monoid s) => Applicative (StateTRep m s) where
pure a = StateTRep (return (mempty, a))
{-# INLINE pure #-}
StateTRep mf <*> StateTRep ma = StateTRep $ do
(s, f) <- mf
(s', a) <- ma
return (mappend s s', f a)
{-# INLINE (<*>) #-}
newtype RWSTRep w m s a = RWSTRep { unRWSTRep :: m (s, a, w) }
instance Monad m => Functor (RWSTRep w m s) where
fmap f (RWSTRep m) = RWSTRep $ do
(s, a, w) <- m
return (s, f a, w)
{-# INLINE fmap #-}
instance (Monad m, Semigroup s, Semigroup w) => Apply (RWSTRep w m s) where
RWSTRep mf <.> RWSTRep ma = RWSTRep $ do
(s, f, w) <- mf
(s', a, w') <- ma
return (s <> s', f a, w <> w')
{-# INLINE (<.>) #-}
instance (Monad m, Monoid s, Monoid w) => Applicative (RWSTRep w m s) where
pure a = RWSTRep (return (mempty, a, mempty))
{-# INLINE pure #-}
RWSTRep mf <*> RWSTRep ma = RWSTRep $ do
(s, f, w) <- mf
(s', a, w') <- ma
return (mappend s s', f a, mappend w w')
{-# INLINE (<*>) #-}