microlens-mtl 0.1.0.0 → 0.1.1.0

raw patch · 4 files changed

+548/−26 lines, 4 filesdep +transformersdep +transformers-compatPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: transformers, transformers-compat

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• microlens-mtl.cabal +8/−6
• src/Lens/Micro/Mtl.hs +256/−20
• src/Lens/Micro/Mtl/Zoom.hs +277/−0

@@ -0,0 +1,7 @@+# 0.1.1.0++* Added `zoom` and `magnify`.++# 0.1.0.0++Initial release.

@@ -1,10 +1,9 @@ name:                microlens-mtl-version:             0.1.0.0+version:             0.1.1.0 synopsis:            microlens support for Reader/Writer/State from mtl description:-  This package contains functions (like 'view' or '+=') which work on-  @Control.Monad.Reader.MonadReader@, @Control.Monad.Writer.MonadWriter@, and-  @Control.Monad.State.MonadState@ from the mtl package.+  This package contains functions (like 'view' or '+=') which work   +  on 'MonadReader', 'MonadWriter', and 'MonadState' from the mtl package. license:             BSD3 license-file:        LICENSE author:              Artyom@@ -14,7 +13,8 @@ -- copyright:            category:            Data, Lenses build-type:          Simple--- extra-source-files:  README.md+extra-source-files:+  CHANGELOG.md cabal-version:       >=1.10  source-repository head@@ -23,10 +23,12 @@  library   exposed-modules:     Lens.Micro.Mtl-  -- other-modules:       +  other-modules:       Lens.Micro.Mtl.Zoom   -- other-extensions:       build-depends:       base >=4.4 && <5                      , microlens ==0.1.*                      , mtl >=2.0.1 && <2.3+                     , transformers >=0.2 && <0.5+                     , transformers-compat >=0.4 && <1   hs-source-dirs:      src   default-language:    Haskell2010

@@ -1,7 +1,22 @@+{-# LANGUAGE+CPP,+MultiParamTypeClasses,+FunctionalDependencies,+FlexibleInstances,+UndecidableInstances,+TypeFamilies+  #-}++-- This is needed because ErrorT is deprecated.+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++ module Lens.Micro.Mtl (   view,   use,+  zoom,+  magnify,   (.=), (%=),   (+=), (-=), (*=), (//=), )@@ -9,68 +24,86 @@   import Control.Applicative-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State+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.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+-- microlens import Lens.Micro import Lens.Micro.Extras+-- Internal modules+import Lens.Micro.Mtl.Zoom +#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif  {- |-'view' is a synonym for ('^.'), generalised for 'MonadReader' (since-functions are instances of the 'MonadReader' class).+'view' is a synonym for ('^.'), generalised for 'MonadReader' (we are able to use it instead of ('^.') since functions are instances of the 'MonadReader' class):  >>> view _1 (1, 2) 1 -It's often used when dealing with environment, for instance:+When you're using 'Reader.Reader' for config and your config type has lenses generated for it, most of the time you'll be using 'view' instead of 'Reader.asks':  @ doSomething :: ('MonadReader' Config m) => m Int doSomething = do-  thingy        <- 'view' setting1  -- same as “'asks' (^. setting1)”+  thingy        <- 'view' setting1  -- same as “'Reader.asks' ('^.' setting1)”   anotherThingy <- 'view' setting2   ... @ -} view :: MonadReader s m => Getting a s a -> m a-view l = asks (getConst . l Const)+view l = Reader.asks (getConst #. l Const) {-# INLINE view #-}  {- | 'use' is 'view' which implicitly operates on the state. +When your state type has lenses generated for it, most of the time you'll be using 'use' instead of 'State.gets'.+ @-'use' l = 'gets' ('view' l)+'use' l = 'State.gets' ('view' l) @ -} use :: MonadState s m => Getting a s a -> m a-use l = gets (view l)+use l = State.gets (view l) {-# INLINE use #-}   infix  4 .=, %= infix  4 +=, -=, *=, //=+infixr 2 `zoom`, `magnify`  {- |-Assign value to the target. This is '.~' which works in 'State'.+Assign value to the target. This is ('.~') which works in 'MonadState'.  @-l '.=' b = 'modify' (l '.~' b)+l '.=' b = 'State.modify' (l '.~' b) @ -} (.=) :: MonadState s m => ASetter s s a b -> b -> m ()-l .= b = modify (l .~ b)+l .= b = State.modify (l .~ b) {-# INLINE (.=) #-}  {- |-Apply a function to the target. This is '%~' which works in 'State'.+Apply a function to the target. This is ('%~') which works in 'MonadState'.  >>> execState (do _1 %= (+1); _2 %= reverse) (1,"hello") (2,"olleh") -} (%=) :: (MonadState s m) => ASetter s s a b -> (a -> b) -> m ()-l %= f = modify (l %~ f)+l %= f = State.modify (l %~ f) {-# INLINE (%=) #-}  {- |@@ -81,7 +114,7 @@ @ -} (+=) :: (MonadState s m, Num a) => ASetter s s a a -> a -> m ()-l += b = modify (l +~ b)+l += b = State.modify (l +~ b) {-# INLINE (+=) #-}  {- |@@ -92,7 +125,7 @@ @ -} (-=) :: (MonadState s m, Num a) => ASetter s s a a -> a -> m ()-l -= b = modify (l -~ b)+l -= b = State.modify (l -~ b) {-# INLINE (-=) #-}  {- |@@ -103,17 +136,220 @@ @ -} (*=) :: (MonadState s m, Num a) => ASetter s s a a -> a -> m ()-l *= b = modify (l *~ b)+l *= b = State.modify (l *~ b) {-# INLINE (*=) #-}  {- | Divide the target by a number.  @-l //= x = l %= (/x)+l '//=' x = l '%=' (/x) @ -} (//=) :: (MonadState s m, Fractional a) => ASetter s s a a -> a -> m ()-l //= a = modify (l //~ a)+l //= a = State.modify (l //~ a) {-# INLINE (//=) #-} +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+  {- |+When you're in a state monad, this function lets you operate on a part of your state. For instance, if your state was a record containing a @position@ field, after zooming @position@ would become your whole state (and when you modify it, the bigger structure would be modified as well).++(Your 'Lazy.State' \/ 'Lazy.StateT' or 'Lazy.RWS' \/ 'Lazy.RWST' can be anywhere in the stack, but you can't use 'zoom' with arbitrary 'MonadState' because it doesn't provide any methods to change the type of the state. See <https://github.com/ekmett/lens/issues/316 this issue> for details.)++For the sake of the example, let's define some types first:++@+data Position = Position {+  _x, _y :: Int }++data Player = Player {+  _position :: Position,+  ... }++data Game = Game {+  _player :: Player,+  _obstacles :: [Position],+  ... }++concat \<$\> mapM makeLenses [''Position, ''Player, ''Game]+@++Now, here's an action that moves the player north-east:++@+moveNE :: 'Lazy.State' Game ()+moveNE = do+  player.position.x '+=' 1+  player.position.y '+=' 1+@++With 'zoom', you can use @player.position@ to focus just on a part of the state:++@+moveNE :: 'Lazy.State' Game ()+moveNE = do+  'zoom' (player.position) $ do+    x '+=' 1+    y '+=' 1+@++You can just as well use it for retrieving things out of the state:++@+getCoords :: 'Lazy.State' Game (Int, Int)+getCoords = 'zoom' (player.position) ((,) '<$>' 'use' x '<*>' 'use' y)+@++Or more explicitly:++@+getCoords = 'zoom' (player.position) $ do+  x' <- 'use' x+  y' <- 'use' y+  return (x', y')+@++When you pass a traversal to 'zoom', it'll work as a loop. For instance, here we move all obstacles:++@+moveObstaclesNE :: 'Lazy.State' Game ()+moveObstaclesNE = do+  'zoom' (obstacles.each) $ do+    x '+=' 1+    y '+=' 1+@++If the action returns a result, all results would be combined with '<>' – the same way they're combined when '^.' is passed a traversal. In this example, @moveObstaclesNE@ returns a list of old coordinates of obstacles in addition to moving them:++@+moveObstaclesNE = do+  xys <- 'zoom' (obstacles.each) $ do+    -- Get old coordinates.+    x' <- 'use' x+    y' <- 'use' y+    -- Update them.+    x '.=' x' + 1+    y '.=' y' + 1+    -- Return a single-element list with old coordinates.+    return [(x', y')]+  ...+@+  -}+  zoom :: ((s -> Zoomed m c s) -> t -> Zoomed m c t) -> m c -> n c++instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) s t where+  zoom l (Strict.StateT m) = Strict.StateT $ unfocusing #. l (Focusing #. m)+  {-# INLINE zoom #-}++instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) s t where+  zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing #. l (Focusing #. 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 Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where+  zoom l (IdentityT m) = IdentityT (zoom l 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 l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith #. l (FocusingWith #. 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 l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r)+  {-# INLINE zoom #-}++instance (Monoid w, Zoom m n s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) s t where+  zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Strict.runWriterT+  {-# INLINE zoom #-}++instance (Monoid w, Zoom m n s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) s t where+  zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Lazy.runWriterT+  {-# INLINE zoom #-}++instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where+  zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT+  {-# INLINE zoom #-}++instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where+  zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #. l (FocusingMay #. afb)) . liftM May . runMaybeT+  {-# INLINE zoom #-}++instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where+  zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runErrorT+  {-# INLINE zoom #-}++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 #-}++-- TODO: instance Zoom m m a a => Zoom (ContT r m) (ContT r m) a a where++class (Magnified m ~ Magnified n, MonadReader b m, MonadReader a n) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where+  {- |+This is an equivalent of 'Reader.local' which lets you apply a getter to your environment instead of merely applying a function (and it also lets you change the type of the environment).++@+'Reader.local'   :: (r -> r)   -> 'Reader.Reader' r a -> 'Reader.Reader' r a+'magnify' :: Getter r x -> 'Reader.Reader' x a -> 'Reader.Reader' r a+@++'magnify' works with 'Reader.Reader' \/ 'Reader.ReaderT', 'Lazy.RWS' \/ 'Lazy.RWST', and @(->)@.++Here's an example of 'magnify' being used to work with a part of a bigger config. First, the types:++@+data URL = URL {+  _protocol :: Maybe String,+  _path :: String }++data Config = Config {+  _base :: URL,+  ... }++makeLenses ''URL+makeLenses ''Config+@++Now, let's define a function which returns the base url:++@+getBase :: 'Reader.Reader' Config String+getBase = do+  protocol \<- 'Data.Maybe.fromMaybe' \"https\" '<$>' 'view' (base.protocol)+  path     \<- 'view' (base.path)+  return (protocol ++ path)+@++With 'magnify', we can factor out @base@:++@+getBase = 'magnify' base $ do+  protocol \<- 'Data.Maybe.fromMaybe' \"https\" '<$>' 'view' protocol+  path     \<- 'view' path+  return (protocol ++ path)+@+  -}+  magnify :: ((b -> Magnified m c b) -> a -> Magnified m c a) -> m c -> n c++instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where+  magnify l (ReaderT m) = ReaderT $ getEffect #. l (Effect #. m)+  {-# INLINE magnify #-}++instance Magnify ((->) b) ((->) a) b a where+  magnify l f = Reader.asks (getConst #. l (Const #. f))+  {-# INLINE magnify #-}++instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) b a where+  magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS #. l (EffectRWS #. m)+  {-# INLINE magnify #-}++instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where+  magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m)+  {-# INLINE magnify #-}++instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where+  magnify l (IdentityT m) = IdentityT (magnify l m)+  {-# INLINE magnify #-}

@@ -0,0 +1,277 @@+{-# LANGUAGE+CPP,+MultiParamTypeClasses,+FunctionalDependencies,+FlexibleContexts,+FlexibleInstances,+UndecidableInstances,+ScopedTypeVariables,+RankNTypes,+TypeFamilies,+KindSignatures+  #-}++-- This is needed because ErrorT is deprecated.+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+++-- This module was copied practically verbatim from lens.+module Lens.Micro.Mtl.Zoom where+++import Control.Applicative+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++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#else+import Unsafe.Coerce+#endif++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif++------------------------------------------------------------------------------+-- Data.Profunctor.Unsafe+------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 708+( #. ) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c)+( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b++( .# ) :: Coercible b a => (b -> c) -> (a -> b) -> (a -> c)+( .# ) pbc _ = coerce pbc+#else+( #. ) :: (b -> c) -> (a -> b) -> (a -> c)+( #. ) _ = unsafeCoerce++( .# ) :: (b -> c) -> (a -> b) -> (a -> c)+( .# ) pbc _ = unsafeCoerce pbc+#endif++------------------------------------------------------------------------------+-- Zoomed+------------------------------------------------------------------------------++-- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type.+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)++------------------------------------------------------------------------------+-- Focusing+------------------------------------------------------------------------------++-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.State.StateT'.+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)+  {-# INLINE fmap #-}++instance (Monad m, Monoid s) => Applicative (Focusing m s) where+  pure a = Focusing (return (mempty, a))+  {-# INLINE pure #-}+  Focusing mf <*> Focusing ma = Focusing $ do+    (s, f) <- mf+    (s', a) <- ma+    return (mappend s s', f a)+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- FocusingWith+------------------------------------------------------------------------------++-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.RWS.RWST'.+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)+  {-# INLINE fmap #-}++instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where+  pure a = FocusingWith (return (mempty, a, mempty))+  {-# INLINE pure #-}+  FocusingWith mf <*> FocusingWith ma = FocusingWith $ do+    (s, f, w) <- mf+    (s', a, w') <- ma+    return (mappend s s', f a, mappend w w')+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- FocusingPlus+------------------------------------------------------------------------------++-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Writer.WriterT'.+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)+  {-# INLINE fmap #-}++instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where+  pure = FocusingPlus . pure+  {-# INLINE pure #-}+  FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka)+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- FocusingOn+------------------------------------------------------------------------------++-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Trans.Maybe.MaybeT' or 'Control.Monad.Trans.List.ListT'.+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)+  {-# INLINE fmap #-}++instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where+  pure = FocusingOn . pure+  {-# INLINE pure #-}+  FocusingOn kf <*> FocusingOn ka = FocusingOn (kf <*> ka)+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- May+------------------------------------------------------------------------------++-- | Make a 'Monoid' out of 'Maybe' for error handling.+newtype May a = May { getMay :: Maybe a }++instance Monoid a => Monoid (May a) where+  mempty = May (Just mempty)+  {-# INLINE mempty #-}+  May Nothing `mappend` _ = May Nothing+  _ `mappend` May Nothing = May Nothing+  May (Just a) `mappend` May (Just b) = May (Just (mappend a b))+  {-# INLINE mappend #-}++------------------------------------------------------------------------------+-- FocusingMay+------------------------------------------------------------------------------++-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Error.ErrorT'.+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)+  {-# INLINE fmap #-}++instance Applicative (k (May s)) => Applicative (FocusingMay k s) where+  pure = FocusingMay . pure+  {-# INLINE pure #-}+  FocusingMay kf <*> FocusingMay ka = FocusingMay (kf <*> ka)+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- Err+------------------------------------------------------------------------------++-- | Make a 'Monoid' out of 'Either' for error handling.+newtype Err e a = Err { getErr :: Either e a }++instance Monoid a => Monoid (Err e a) where+  mempty = Err (Right mempty)+  {-# INLINE 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))+  {-# INLINE mappend #-}++------------------------------------------------------------------------------+-- FocusingErr+------------------------------------------------------------------------------++-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Error.ErrorT'.+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)+  {-# INLINE fmap #-}++instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where+  pure = FocusingErr . pure+  {-# INLINE pure #-}+  FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka)+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- Magnified+------------------------------------------------------------------------------++-- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type.+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++-----------------------------------------------------------------------------+--- Effect+-------------------------------------------------------------------------------++-- | Wrap a monadic effect with a phantom type argument.+newtype Effect m r a = Effect { getEffect :: m r }+-- type role Effect representational nominal phantom++instance Functor (Effect m r) where+  fmap _ (Effect m) = Effect m+  {-# INLINE fmap #-}++instance (Monad m, Monoid r) => Monoid (Effect m r a) where+  mempty = Effect (return mempty)+  {-# INLINE mempty #-}+  Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb)+  {-# INLINE mappend #-}++instance (Monad m, Monoid r) => Applicative (Effect m r) where+  pure _ = Effect (return mempty)+  {-# INLINE pure #-}+  Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb)+  {-# INLINE (<*>) #-}++------------------------------------------------------------------------------+-- EffectRWS+------------------------------------------------------------------------------++-- | Wrap a monadic effect with a phantom type argument. Used when magnifying 'Control.Monad.RWS.RWST'.+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+  {-# INLINE fmap #-}++instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where+  pure _ = EffectRWS $ \st -> return (mempty, st, mempty)+  {-# INLINE pure #-}+  EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w')+  {-# INLINE (<*>) #-}+