Permalink
Browse files

Added Zoom and Magnify.

  • Loading branch information...
1 parent 03cadc6 commit 445fc67fc8329cef2850a484227252b0d6ef544e @ekmett committed Aug 15, 2012
Showing with 216 additions and 79 deletions.
  1. +3 −3 lens.cabal
  2. +1 −1 src/Control/Lens.hs
  3. +116 −35 src/Control/Lens/Getter.hs
  4. +84 −32 src/Control/Lens/Type.hs
  5. +12 −8 tests/properties.hs
View
@@ -1,6 +1,6 @@
name: lens
category: Data, Lenses
-version: 2.2
+version: 2.3
license: BSD3
cabal-version: >= 1.8
license-file: LICENSE
@@ -33,12 +33,12 @@ description:
.
The core of this hierarchy looks like:
.
- <<https://github.com/ekmett/lens/wiki/images/Hierarchy-2.2.png>>
+ <<https://github.com/ekmett/lens/wiki/images/Hierarchy-2.3.png>>
.
You can compose any two elements of the hierarchy above using (.) from the Prelude, and you can
use any element of the hierarchy as any type it links to above it.
.
- The result is their lowest upper bound in the hierarchy (or an error f that bound doesn't exist).
+ The result is their lowest upper bound in the hierarchy (or an error if that bound doesn't exist).
.
For instance:
.
View
@@ -41,7 +41,7 @@
--
-- <http://github.com/ekmett/lens/wiki>
--
--- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-1.8.png>>
+-- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-2.3.png>>
----------------------------------------------------------------------------
module Control.Lens
( module Control.Lens.Type
View
@@ -1,4 +1,8 @@
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
-------------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Getter
@@ -51,13 +55,26 @@ module Control.Lens.Getter
, uses
, query
, queries
+ , Magnify(..)
) where
import Control.Applicative
import Control.Applicative.Backwards
import Control.Lens.Internal
import Control.Monad.Reader.Class as Reader
import Control.Monad.State.Class 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.Reader
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
import Data.Functor.Compose
import Data.Monoid
@@ -256,6 +273,44 @@ a ^. l = runAccessor (l Accessor a)
{-# INLINE (^.) #-}
-------------------------------------------------------------------------------
+-- MonadState
+-------------------------------------------------------------------------------
+
+-- |
+-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or
+-- 'Getter' in the current state, or use a summary of a
+-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
+-- to a monoidal value.
+--
+-- @
+-- use :: 'MonadState' a m => 'Getter' a c -> m c
+-- use :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Fold.Fold' a r -> m r
+-- use :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a c -> m c
+-- use :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a c -> m c
+-- use :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a r -> m r
+-- @
+use :: MonadState a m => Getting c a c -> m c
+use l = State.gets (view l)
+{-# INLINE use #-}
+
+-- |
+-- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or
+-- 'Getter' in the current state, or use a summary of a
+-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
+-- points to a monoidal value.
+--
+-- @
+-- uses :: 'MonadState' a m => 'Getter' a c -> (c -> e) -> m e
+-- uses :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Fold.Fold' a c -> (c -> r) -> m r
+-- uses :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a c -> (c -> e) -> m e
+-- uses :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a c -> (c -> e) -> m e
+-- uses :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a c -> (c -> r) -> m r
+-- @
+uses :: MonadState a m => Getting e a c -> (c -> e) -> m e
+uses l f = State.gets (views l f)
+{-# INLINE uses #-}
+
+-------------------------------------------------------------------------------
-- MonadReader
-------------------------------------------------------------------------------
@@ -293,40 +348,66 @@ queries :: MonadReader a m => Getting e a c -> (c -> e) -> m e
queries l f = Reader.asks (views l f)
{-# INLINE queries #-}
--------------------------------------------------------------------------------
--- MonadState
--------------------------------------------------------------------------------
--- |
--- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or
--- 'Getter' in the current state, or use a summary of a
--- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
--- to a monoidal value.
---
--- @
--- use :: 'MonadState' a m => 'Getter' a c -> m c
--- use :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Fold.Fold' a r -> m r
--- use :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a c -> m c
--- use :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a c -> m c
--- use :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a r -> m r
--- @
-use :: MonadState a m => Getting c a c -> m c
-use l = State.gets (view l)
-{-# INLINE use #-}
+-- | This class allows us to use 'magnify' part of the environment, changing the environment supplied by
+-- many different monad transformers. Unlike 'focus' this can change the environment of a deeply nested monad transformer.
+--
+-- Also, unlike 'focus', this can be used with any valid 'Getter', but cannot be used with a 'Traversal' or 'Fold'.
+class (MonadReader b m, MonadReader a n) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where
+ -- | Run a monadic action in a larger environment than it was defined in, using a 'Getter'.
+ --
+ -- This acts like 'Control.Monad.Reader.Class.local', but can in many cases change the type of the environment as well.
+ --
+ -- This is commonly used to lift actions in a simpler Reader monad into a state monad with a larger state type.
+ --
+ -- This can be used to edit pretty much any monad transformer stack with an environment in it:
+ --
+ -- @
+ -- magnify :: 'Getter' a b -> (b -> c) -> a -> c
+ -- magnify :: 'Getter' a b -> RWS a w s c -> RWST b w s c
+ -- magnify :: 'Getter' a b -> ErrorT e (Reader b) c -> ErrorT e (Reader a) c
+ -- magnify :: 'Getter' a b -> ListT (ReaderT b (StateT s)) c -> ListT (ReaderT a (StateT s)) c
+ -- ...
+ -- @
+ magnify :: Getter a b -> m c -> n c
--- |
--- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or
--- 'Getter' in the current state, or use a summary of a
--- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
--- points to a monoidal value.
---
--- @
--- uses :: 'MonadState' a m => 'Getter' a c -> (c -> e) -> m e
--- uses :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Fold.Fold' a c -> (c -> r) -> m r
--- uses :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a c -> (c -> e) -> m e
--- uses :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a c -> (c -> e) -> m e
--- uses :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a c -> (c -> r) -> m r
--- @
-uses :: MonadState a m => Getting e a c -> (c -> e) -> m e
-uses l f = State.gets (views l f)
-{-# INLINE uses #-}
+instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where
+ magnify l (ReaderT m) = ReaderT $ \e -> m (e^.l)
+
+instance Magnify ((->) b) ((->) a) b a where
+ magnify l bc a = bc (view l a)
+
+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 $ \a w -> m (a^.l) w
+
+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 $ \a w -> m (a^.l) w
+
+instance Magnify m n b a => Magnify (Strict.StateT s m) (Strict.StateT s n) b a where
+ magnify l (Strict.StateT m) = Strict.StateT $ magnify l . m
+
+instance Magnify m n b a => Magnify (Lazy.StateT s m) (Lazy.StateT s n) b a where
+ magnify l (Lazy.StateT m) = Lazy.StateT $ magnify l . m
+
+instance (Monoid w, Magnify m n b a) => Magnify (Strict.WriterT w m) (Strict.WriterT w n) b a where
+ magnify l (Strict.WriterT m) = Strict.WriterT (magnify l m)
+
+instance (Monoid w, Magnify m n b a) => Magnify (Lazy.WriterT w m) (Lazy.WriterT w n) b a where
+ magnify l (Lazy.WriterT m) = Lazy.WriterT (magnify l m)
+
+instance Magnify m n b a => Magnify (ListT m) (ListT n) b a where
+ magnify l (ListT m) = ListT (magnify l m)
+
+instance Magnify m n b a => Magnify (MaybeT m) (MaybeT n) b a where
+ magnify l (MaybeT m) = MaybeT (magnify l m)
+
+instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where
+ magnify l (IdentityT m) = IdentityT (magnify l m)
+
+instance (Error e, Magnify m n b a) => Magnify (ErrorT e m) (ErrorT e n) b a where
+ magnify l (ErrorT m) = ErrorT (magnify l m)
+
+instance Magnify m m a a => Magnify (ContT r m) (ContT r m) a a where
+ magnify l (ContT m) = ContT $ \k -> do
+ r <- Reader.ask
+ magnify l (m (magnify (to (const r)) . k))
View
@@ -4,6 +4,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
@@ -61,6 +62,7 @@ module Control.Lens.Type
-- * Traversing and Lensing
, Focus(..)
+ , Zoom(..)
-- * Common Lenses
-- ** Tuples
@@ -109,8 +111,18 @@ import Control.Monad
import Control.Monad.State.Class 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.Reader
+-- import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.Maybe
import Data.Functor.Identity
+import Data.Monoid
infixr 4 %%~
infix 4 %%=
@@ -274,6 +286,7 @@ l %%= f = do
#endif
{-# INLINE (%%=) #-}
+
-- | This class allows us to use 'focus' on a number of different monad
-- transformers.
class Focus st where
@@ -318,7 +331,7 @@ instance Focus Strict.StateT where
focus_ l m = Strict.StateT $
unfocusing . l (Focusing . Strict.runStateT (liftM skip m))
{-# INLINE focus_ #-}
- setFocus l m = Strict.state $
+ setFocus l m = State.state $
(,) () . runIdentity . l (Identity . snd . Strict.runState m)
instance Focus Lazy.StateT where
@@ -328,7 +341,7 @@ instance Focus Lazy.StateT where
focus_ l m = Lazy.StateT $
unfocusing . l (Focusing . Lazy.runStateT (liftM skip m))
{-# INLINE focus_ #-}
- setFocus l m = Lazy.state $
+ setFocus l m = State.state $
(,) () . runIdentity . l (Identity . snd . Lazy.runState m)
{-# INLINE setFocus #-}
@@ -342,40 +355,79 @@ instance Focus ReaderT where
{-# INLINE focus_ #-}
setFocus _ _ = return () -- BOOORING
--------------------------------------------------------------------------------
--- Common Lenses
--------------------------------------------------------------------------------
+-- | This class allows us to use 'zoom' in, changing the State supplied by
+-- many different monad transformers. Unlike 'focus' this can change the state
+-- of a deeply nested monad transformer. However, also unlike 'focus' it can
+-- only be used on an actual 'Lens' or 'Control.Lens.Iso.Iso' and cannot accept
+-- a 'Control.Lens.Traversal.Traversal'
+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 'Simple' 'Lens'.
+ --
+ -- This is commonly used to lift actions in a simpler state monad into a
+ -- state monad with a larger state type.
+ --
+ -- This can be used to edit pretty much any monad transformer stack with a state in it:
+ --
+ -- @
+ -- zoom :: 'Monad' m => 'Simple' 'Lens' a b -> StateT b m c -> StateT a m c
+ -- zoom :: 'Monad' m => 'Simple' 'Lens' a b -> RWST r w b m c -> RWST r w a m c
+ -- zoom :: 'Monad' m => 'Simple' 'Lens' a b -> ErrorT e (RWST r w b m c) -> ErrorT e (RWST r w a m c)
+ -- zoom :: 'Monad' m => 'Simple' 'Lens' a b -> ErrorT e (RWST r w b m c) -> ErrorT e (RWST r w a m c)
+ -- ...
+ -- @
+ zoom :: SimpleLensLike (IndexedStore s s) t s -> m c -> n c
-{-
--- | This is a lens that can change the value (and type) of the first field of
--- a pair.
---
--- >>> import Control.Lens
--- >>> (1,2)^._1
--- 1
---
--- >>> _1 .~ "hello" $ (1,2)
--- ("hello",2)
---
--- @_1 :: 'Functor' f => (a -> f b) -> (a,c) -> f (a,c)@
-_1 :: Lens (a,c) (b,c) a b
-_1 f (a,c) = (\b -> (b,c)) <$> f a
-{-# INLINE _1 #-}
+instance Monad m => Zoom (Strict.StateT s m) (Strict.StateT t m) s t where
+ zoom = focus . clone
--- | As '_1', but for the second field of a pair.
---
--- @
--- 'Control.Lens.Fold.anyOf' '_2' :: (c -> 'Bool') -> (a, c) -> 'Bool'
--- 'Data.Traversable.traverse' '.' '_2' :: ('Applicative' f, 'Data.Traversable.Traversable' t) => (a -> f b) -> t (c, a) -> f (t (c, b))
--- 'Control.Lens.Fold.foldMapOf' ('Data.Traversable.traverse' '.' '_2') :: ('Data.Traversable.Traversable' t, 'Data.Monoid.Monoid' m) => (c -> m) -> t (b, c) -> m
--- @
---
--- @_2 :: 'Functor' f => (a -> f b) -> (c,a) -> f (c,b)@
-_2 :: Lens (c,a) (c,b) a b
-_2 f (c,a) = (,) c <$> f a
-{-# INLINE _2 #-}
+instance Monad m => Zoom (Lazy.StateT s m) (Lazy.StateT t m) s t where
+ zoom = focus . clone
+
+instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where
+ zoom l (ReaderT m) = ReaderT (zoom l . m)
+
+instance (Monoid w, Zoom m n s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) s t where
+ zoom l (Strict.WriterT m) = Strict.WriterT (zoom l m)
+
+instance (Monoid w, Zoom m n s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) s t where
+ zoom l (Lazy.WriterT m) = Lazy.WriterT (zoom l m)
+
+instance (Monoid w, Monad m) => Zoom (Strict.RWST r w s m) (Strict.RWST r w t m) s t where
+ zoom l (Strict.RWST m) = Strict.RWST $ \ r t -> case l (IndexedStore id) t of
+ IndexedStore st s -> do
+ (a,s',w) <- m r s
+ return (a,st s',w)
+
+instance (Monoid w, Monad m) => Zoom (Lazy.RWST r w s m) (Lazy.RWST r w t m) s t where
+ zoom l (Lazy.RWST m) = Lazy.RWST $ \ r t -> case l (IndexedStore id) t of
+ IndexedStore st s -> do
+ (a,s',w) <- m r s
+ return (a,st s',w)
+
+instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where
+ zoom l (ErrorT m) = ErrorT (zoom l m)
+
+instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where
+ zoom l (ListT m) = ListT (zoom l m)
+
+instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where
+ zoom l (IdentityT m) = IdentityT (zoom l m)
+
+instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where
+ zoom l (MaybeT m) = MaybeT (zoom l m)
+
+{-
+instance Zoom m m a a => Zoom (ContT r m) (ContT r m) a a where
+ zoom l (ContT m) = ContT $ \k -> do
+ IndexedState ba a <- State.gets (l (IndexedState id))
+ ...
-}
+-------------------------------------------------------------------------------
+-- Common Lenses
+-------------------------------------------------------------------------------
+
-- | This lens can be used to change the result of a function but only where
-- the arguments match the key given.
resultAt :: Eq e => e -> Simple Lens (e -> a) a
Oops, something went wrong.

0 comments on commit 445fc67

Please sign in to comment.