packages feed

lens 0.1 → 0.2

raw patch · 4 files changed

+707/−160 lines, 4 files

Files

lens.cabal view
@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses-version:       0.1+version:       0.2 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -22,12 +22,14 @@ library   exposed-modules:     Control.Lens-    Control.Lens.Multi-  ghc-options:    -Wall -fwarn-tabs -O2 -fdicts-cheap+    Control.Lens.Rep+  ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields   hs-source-dirs: src   build-depends:     base             == 4.*,-    containers       >= 0.3     && < 0.6,-    mtl              >= 2.1.1   && < 2.2,-    template-haskell >= 2.4     && < 2.8,-    transformers     >= 0.2     && < 0.4+    containers       >= 0.3   && < 0.6,+    mtl              >= 2.1.1 && < 2.2,+    template-haskell >= 2.4   && < 2.8,+    transformers     >= 0.2   && < 0.4+  other-extensions:+    RankNTypes TemplateHaskell
src/Control/Lens.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, TemplateHaskell #-}+{-# LANGUAGE RankNTypes, TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Lens@@ -7,10 +7,10 @@ -- License     :  BSD-style (see the file LICENSE) -- Maintainer  :  Edward Kmett <ekmett@gmail.com> -- Stability   :  provisional--- Portability :  portable+-- Portability :  RankNTypes, TemplateHaskell ----- A self-contained lens library with lenses that are compatible with other--- van Laarhoven lens libraries.+-- This package provides lenses that are compatible with other van+-- Laarhoven lens libraries, while reducing the complexty of the imports. -- -- Lenses produced by this library are compatible with other van Laarhoven -- lens family libraries, such as lens-family, lens-family-core and@@ -23,12 +23,22 @@ -- > foo :: Functor f => (Foo -> f Foo) -> Bar -> f Bar -- -- and then you can compose it with other lenses using (.).+--+-- This package provides lenses, lens families, setters, setter families,+-- getters, multilenses, multi-getters, and multi-lens families in such+-- a way that they can all be composed automatically with (.).+-- ---------------------------------------------------------------------------- module Control.Lens   (   -- * Lenses     Lens   , LensFamily+  , Getter+  , Setter+  , SetterFamily+  , MultiLens+  , MultiLensFamily    -- * Constructing lenses   , makeLenses@@ -37,51 +47,92 @@   , lens   , iso   , clone+  , getting+  , gettingMany+  , setting -  -- * Reading from lenses-  , getL, modL, setL+  -- * Manipulating Values+  , reading+  , modifying+  , writing   , (^.), (^$)   , (^%=), (^=), (^+=), (^-=), (^*=), (^/=), (^||=), (^&&=) -  -- * Manipulating state+  -- * Manipulating State   , access   , Focus(..)   , (%=), (~=), (%%=), (+=), (-=), (*=), (//=), (||=), (&&=) -  -- * Common lenses-  , fstLens-  , sndLens-  , mapLens-  , intMapLens-  , setLens-  , intSetLens+  -- * Lenses and LensFamilies+  , fstL+  , sndL+  , keyL+  , intKeyL+  , memberL+  , intMemberL+  , identityL+  , atL -  -- ** Getters-  , Getter-  , getting+  -- * MultiGetters+  , folded -  -- ** Setters-  , Setter-  , SetterFamily-  , setting+  -- ** MultiGetter combinators+  , mapOf+  , foldMapOf+  , foldrOf+  , foldOf+  , toListOf+  , anyOf, allOf+  , andOf, orOf+  , productOf, sumOf+  , traverseOf_+  , forOf_+  , sequenceAOf_+  , mapMOf_+  , forMOf_+  , sequenceOf_+  , asumOf, msumOf+  , concatMapOf+  , concatOf+  , elemOf+  , notElemOf +  -- * MultiLenses+  , constML+  , keyML+  , intKeyML+  , headML+  , tailML+  , leftML+  , elementML++  -- ** MultiLens combinators+  , traverseOf+  , mapMOf+  , sequenceAOf+  , sequenceOf+   -- * Implementation details-  , IndexedStore(..)-  , Focusing(..)+  , IndexedStore+  , Focusing+  , Traversal   ) where -import           Control.Applicative-import           Control.Monad (liftM)+import           Control.Applicative              as Applicative+import           Control.Monad (liftM, MonadPlus(..)) import           Control.Monad.State.Class-import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Lazy   as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import           Control.Monad.Trans.Reader import           Data.Char (toLower)+import           Data.Foldable                    as Foldable import           Data.Functor.Identity-import           Data.IntMap as IntMap-import           Data.IntSet as IntSet-import           Data.Map as Map-import           Data.Set as Set+import           Data.IntMap                      as IntMap+import           Data.IntSet                      as IntSet+import           Data.Map                         as Map+import           Data.Monoid+import           Data.Set                         as Set+import           Data.Traversable import           Language.Haskell.TH  infixl 8 ^.@@ -89,25 +140,36 @@ infix  4 ~=, %=, %%=, +=, -=, *=, //=, &&=, ||= infixr 0 ^$ -type Lens a b                 = forall f. Functor f => (b -> f b) -> a -> f a-type LensFamily a b c d       = forall f. Functor f => (c -> f d) -> a -> f b-type Getter a b               = forall x y z. (b -> Const z x) -> a -> Const z y-type Setter a b               = (b -> Identity b) -> a -> Identity a-type SetterFamily a b c d     = (c -> Identity d) -> a -> Identity b+type Lens a b                = forall f. Functor f => (b -> f b) -> a -> f a+type LensFamily a b c d      = forall f. Functor f => (c -> f d) -> a -> f b+type Getter a b              = forall x y z. (b -> Const z x) -> a -> Const z y+type Setter a b              = (b -> Identity b) -> a -> Identity a+type SetterFamily a b c d    = (c -> Identity d) -> a -> Identity b+type MultiGetter a c         = forall x y m. Monoid m => (c -> Const m x) -> a -> Const m y+type MultiLens a b           = forall f. Applicative f => (b -> f b) -> a -> f a+type MultiLensFamily a b c d = forall f. Applicative f => (c -> f d) -> a -> f b +-- | Build a lens from a getter and a setter lens :: Functor f => (a -> c) -> (d -> a -> b) -> (c -> f d) -> a -> f b lens ac dab cfd a = (`dab` a) <$> cfd (ac a) {-# INLINE lens #-} +-- | Built a lens from an isomorphism or an isomorphism family iso :: Functor f => (a -> c) -> (d -> b) -> (c -> f d) -> a -> f b iso f g h a = g <$> h (f a ) {-# INLINE iso #-} -getting :: (a -> c) -> (c -> Const r d) -> a -> Const r b+-- | Build a getter+getting :: (a -> b) -> Getter a b getting f g a = Const (getConst (g (f a))) {-# INLINE getting #-} -setting :: ((c -> d) -> a -> b) -> (c -> Identity d) -> a -> Identity b+-- | Building a multigetter+gettingMany :: Foldable f => (a -> f b) -> MultiGetter a b+gettingMany f g a = Const (foldMap (getConst . g) (f a))++-- | Build a setter+setting :: ((c -> d) -> a -> b) -> SetterFamily a b c d setting f g a = Identity (f (runIdentity . g) a) {-# INLINE setting #-} @@ -115,55 +177,92 @@ -- Using Lenses ------------------------------------------------------------------------------ -getL :: ((c -> Const c d) -> a -> Const c b) -> a -> c-getL l a = getConst (l Const a)-{-# INLINE getL #-}+-- | Get the value of a 'Getter', 'Lens' or 'LensFamily' or the fold of a+-- 'MultiGetter', 'MultiLens' or 'MultiLensFamily' that points at monoidal+-- values.+reading :: ((c -> Const c d) -> a -> Const c b) -> a -> c+reading l a = getConst (l Const a)+{-# INLINE reading #-} -modL :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b-modL l f a = runIdentity (l (Identity . f) a)-{-# INLINE modL #-}+-- | Modify the target of a 'Lens', 'LensFamily' or all the targets of a+-- 'Multilens', 'MultiLensFamily', 'Setter' or 'SetterFamily'+mapOf, modifying :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b+mapOf l f a = runIdentity (l (Identity . f) a)+modifying = mapOf+{-# INLINE mapOf #-}+{-# INLINE modifying #-} -setL :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b-setL l d a = runIdentity (l (\_ -> Identity d) a)-{-# INLINE setL #-}+-- | Replace the target of a 'Lens', 'LensFamily', 'Setter' or 'SetterFamily'+writing :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b+writing l d a = runIdentity (l (\_ -> Identity d) a)+{-# INLINE writing #-} +-- | Read the value of a 'Getter', 'Lens' or 'LensFamily'.+-- This is the same operation as 'reading'. (^$) :: ((c -> Const c d) -> a -> Const c b) -> a -> c l ^$ a = getConst (l Const a) {-# INLINE (^$) #-} +-- | Read a field from a 'Getter', 'Lens' or 'LensFamily'.+-- The fixity and semantics are such that subsequent field accesses can be+-- performed with (Prelude..) This is the same operation as 'flip reading'+--+-- > ghci> ((0, 1 :+ 2), 3)^.fstL.sndL.getting magnitude+-- > 2.23606797749979 (^.) :: a -> ((c -> Const c d) -> a -> Const c b) -> c a ^. l = getConst (l Const a) {-# INLINE (^.) #-} +-- | Modifies the target of a 'Lens', 'LensFamily', 'Setter', or 'SetterFamily'.+--+-- This is an infix version of 'mapOf' (^%=) :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b l ^%= f = runIdentity . l (Identity . f) {-# INLINE (^%=) #-} +-- | Replaces the target(s) of a 'Lens', 'LensFamily', 'Setter' or 'SetterFamily'.+--+-- This is an infix version of 'writing' (^=) :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b l ^= v = runIdentity . l (Identity . const v) {-# INLINE (^=) #-} +-- | Increment the target(s) of a numerically valued 'Lens' or Setter'+--+-- > ghci> fstL ^+= 1 $ (1,2)+-- > (2,2) (^+=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^+= n = modL l (+ n)+l ^+= n = mapOf l (+ n) {-# INLINE (^+=) #-} +-- | Multiply the target(s) of a numerically valued 'Lens' or Setter'+--+-- > ghci> sndL ^*= 4 $ (1,2)+-- > (1,8) (^*=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^-= n = modL l (`subtract` n)+l ^-= n = mapOf l (`subtract` n) {-# INLINE (^-=) #-} +-- | Decrement the target(s) of a numerically valued 'Lens' or 'Setter'+--+-- > ghci> fstL ^-= 2 $ (1,2)+-- > (-1,2) (^-=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^*= n = modL l (* n)+l ^*= n = mapOf l (* n) {-# INLINE (^*=) #-} +-- | Divide the target(s) of a numerically valued 'Lens' or 'Setter' (^/=) :: Fractional c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^/= n = modL l (/ n)+l ^/= n = mapOf l (/ n) +-- | Logically '||' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' (^||=):: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a-l ^||= n = modL l (|| n)+l ^||= n = mapOf l (|| n) {-# INLINE (^||=) #-} +-- | Logically '&&' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' (^&&=) :: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a-l ^&&= n = modL l (&& n)+l ^&&= n = mapOf l (&& n) {-# INLINE (^&&=) #-}  ------------------------------------------------------------------------------@@ -175,6 +274,9 @@ instance Functor (IndexedStore c d) where   fmap f (IndexedStore g c) = IndexedStore (f . g) c +-- | Cloning a 'Lens' or 'LensFamily' is one way to make sure you arent given+-- something weaker, such as a 'MultiLens' or 'MultiLensFamily', and can be used+-- as a way to pass around lenses that have to be monomorphic in 'f'. clone :: Functor f => ((c -> IndexedStore c d d) -> a -> IndexedStore c d b) -> (c -> f d) -> a -> f b clone f cfd a = case f (IndexedStore id) a of   IndexedStore db c -> db <$> cfd c@@ -184,42 +286,87 @@ -- Common Lenses ------------------------------------------------------------------------------ -fstLens :: LensFamily (a,c) (b,c) a b-fstLens f (a,c) = (\b -> (b,c)) <$> f a-{-# INLINE fstLens #-}+-- | This is a lens family that can change the value (and type) of the first field of+-- a pair. -sndLens :: LensFamily (c,a) (c,b) a b-sndLens f (c,a) = (,) c <$> f a-{-# INLINE sndLens #-}+-- > ghci> (1,2)^.fstL+-- > 1+--+-- > ghci> fstL ^= "hello" $ (1,2)+-- > ("hello",2)+fstL :: LensFamily (a,c) (b,c) a b+fstL f (a,c) = (\b -> (b,c)) <$> f a+{-# INLINE fstL #-} -mapLens :: Ord k => k -> Lens (Map k v) (Maybe v)-mapLens k f m = go <$> f (Map.lookup k m) where+-- | As 'fstL', but for the second field of a pair.+sndL :: LensFamily (c,a) (c,b) a b+sndL f (c,a) = (,) c <$> f a+{-# INLINE sndL #-}++-- | This lens can be used to read, write or delete a member of a 'Map'.+--+-- > ghci> Map.fromList [("hello",12)] ^. keyL "hello"+-- > Just 12+keyL :: Ord k => k -> Lens (Map k v) (Maybe v)+keyL k f m = go <$> f (Map.lookup k m) where   go Nothing   = Map.delete k m   go (Just v') = Map.insert k v' m-{-# INLINE mapLens #-}+{-# INLINE keyL #-} -intMapLens :: Int -> Lens (IntMap v) (Maybe v)-intMapLens k f m = go <$> f (IntMap.lookup k m) where+-- | This lens can be used to read, write or delete a member of an 'IntMap'.+--+-- > ghci> IntMap.fromList [(1,"hello")]  ^. keyL 1+-- > Just "hello"+--+-- > ghci> keyL 2 ^= "goodbye" $ IntMap.fromList [(1,"hello")]+-- > fromList [(1,"hello"),(2,"goodbye")]+intKeyL :: Int -> Lens (IntMap v) (Maybe v)+intKeyL k f m = go <$> f (IntMap.lookup k m) where   go Nothing   = IntMap.delete k m   go (Just v') = IntMap.insert k v' m-{-# INLINE intMapLens #-}+{-# INLINE intKeyL #-} -setLens :: Ord k => k -> Lens (Set k) Bool-setLens k f s = go <$> f (Set.member k s) where++-- | This lens can be used to read, write or delete a member of a 'Set'+--+-- > ghci> memberL 3 ^= False $ Set.fromList [1,2,3,4]+-- > fromList [1,2,4]+memberL :: Ord k => k -> Lens (Set k) Bool+memberL k f s = go <$> f (Set.member k s) where   go False = Set.delete k s   go True  = Set.insert k s-{-# INLINE setLens #-}+{-# INLINE memberL #-} -intSetLens :: Int -> Lens IntSet Bool-intSetLens k f s = go <$> f (IntSet.member k s) where+-- | This lens can be used to read, write or delete a member of an 'IntSet'+--+-- > ghci> intMemberL 3 ^= False $ IntSet.fromList [1,2,3,4]+-- > fromList [1,2,4]+intMemberL :: Int -> Lens IntSet Bool+intMemberL k f s = go <$> f (IntSet.member k s) where   go False = IntSet.delete k s   go True  = IntSet.insert k s-{-# INLINE intSetLens #-}+{-# INLINE intMemberL #-} +-- | This lens can be used to access the contents of the Identity monad+identityL :: LensFamily (Identity a) (Identity b) a b+identityL f (Identity a) = Identity <$> f a+{-# INLINE identityL #-}++-- | This lens can be used to change the result of a function but only where+-- the arguments match the key given.+--+atL :: Eq e => e -> Lens (e -> a) a+atL e afa ea = go <$> afa a where+  a = ea e+  go a' e' | e == e'   = a'+           | otherwise = a+{-# INLINE atL #-}+ ------------------------------------------------------------------------------ -- State ------------------------------------------------------------------------------ +-- | Access a field of a state monad access :: MonadState a m => ((c -> Const c d) -> a -> Const c b) -> m c access l = gets (^. l) {-# INLINE access #-}@@ -229,7 +376,16 @@ instance Monad m => Functor (Focusing m c) where   fmap f (Focusing m) = Focusing (liftM (fmap f) m) +instance (Monad m, Monoid c) => Applicative (Focusing m c) where+  pure a = Focusing (return (mempty, a))+  Focusing mf <*> Focusing ma = Focusing $ do+    (c, f) <- mf+    (d, a) <- ma+    return (mappend c d, f a)++-- | This class allows us to use 'focus' on a number of different monad transformers. class Focus st where+  -- | Use a lens to lift an operation with simpler context into a larger context   focus :: Monad m => ((b -> Focusing m c b) -> a -> Focusing m c a) -> st b m c -> st a m c  instance Focus Strict.StateT where@@ -238,46 +394,253 @@ instance Focus Lazy.StateT where   focus l (Lazy.StateT m) = Lazy.StateT $ \a -> unfocusing (l (Focusing . m) a) +-- | We can focus Reader environments, too! instance Focus ReaderT where   focus l (ReaderT m) = ReaderT $ \a -> liftM undefined $  unfocusing $ l (\b -> Focusing $ (\c -> (c,b)) `liftM` m b) a +-- | Set the value of a field in our monadic state (~=) :: MonadState a m => Setter a b -> b -> m () l ~= b = modify (l ^= b) {-# INLINE (~=) #-} +-- | Modify the value of a field in our monadic state (%=) :: MonadState a m => Setter a b -> (b -> b) -> m () l %= f = modify (l ^%= f) {-# INLINE (%=) #-} +-- | Modify the value of a field in our monadic state and return some information about it (%%=) :: MonadState a m => ((b -> (c,b)) -> a -> (c,a)) -> (b -> (c, b)) -> m c l %%= f = state (l f) {-# INLINE (%%=) #-} +-- | Modify a numeric field in our monadic state by adding to it (+=) :: (MonadState a m, Num b) => Setter a b -> b -> m () l += b = modify $ l ^+= b {-# INLINE (+=) #-} +-- | Modify a numeric field in our monadic state by subtracting from it (-=) :: (MonadState a m, Num b) => Setter a b -> b -> m () l -= b = modify $ l ^-= b {-# INLINE (-=) #-} +-- | Modify a numeric field in our monadic state by multiplying it (*=) :: (MonadState a m, Num b) => Setter a b -> b -> m () l *= b = modify $ l ^*= b {-# INLINE (*=) #-} +-- | Modify a numeric field in our monadic state by dividing it (//=) ::  (MonadState a m, Fractional b) => Setter a b -> b -> m () l //= b = modify $ l ^/= b {-# INLINE (//=) #-} +-- | Modify a boolean field in our monadic state by computing its logical '&&' with another value. (&&=):: MonadState a m => Setter a Bool -> Bool -> m () l &&= b = modify $ l ^&&= b {-# INLINE (&&=) #-} +-- | Modify a boolean field in our monadic state by computing its logical '||' with another value. (||=) :: MonadState a m => Setter a Bool -> Bool -> m () l ||= b = modify $ l ^||= b {-# INLINE (||=) #-} +--------------------------+-- Multigetter combinators+--------------------------++-- | > foldMapOf :: Monoid m => MultiGetter a b -> (b -> m) -> a -> m+foldMapOf :: Monoid m => ((c -> Const m d) -> a -> Const m b) -> (c -> m) -> a -> m+foldMapOf l f = getConst . l (Const . f)+{-# INLINE foldMapOf #-}++-- | > foldOf :: Monoid m => MultiGetter a m -> a -> m+foldOf :: Monoid m => ((m -> Const m n) -> a -> Const m b) -> a -> m+foldOf l = getConst . l Const+{-# INLINE foldOf #-}++-- | > foldrOf :: MultiGetter a b -> (b -> c -> c) -> c -> a -> c+foldrOf :: ((c -> Const (Endo e) d) -> a -> Const (Endo e) b) -> (c -> e -> e) -> e -> a -> e+foldrOf l f z t = appEndo (foldMapOf l (Endo . f) t) z+{-# INLINE foldrOf #-}++-- | > toListOf :: MultiGetter a b -> a -> [b]+toListOf :: ((c -> Const [c] d) -> a -> Const [c] b) -> a -> [c]+toListOf l = foldMapOf l return+{-# INLINE toListOf #-}++andOf :: ((Bool -> Const All d) -> a -> Const All b) -> a -> Bool+andOf l = getAll . foldMapOf l All+{-# INLINE andOf #-}++orOf :: ((Bool -> Const Any d) -> a -> Const Any b) -> a -> Bool+orOf l = getAny . foldMapOf l Any+{-# INLINE orOf #-}++-- | > anyOf :: MultiGetter a b -> (b -> Bool) -> a -> Bool+anyOf :: ((c -> Const Any d) -> a -> Const Any b) -> (c -> Bool) -> a -> Bool+anyOf l f = getAny . foldMapOf l (Any . f)+{-# INLINE anyOf #-}++-- | > allOf :: MultiGetter a b -> (b -> Bool) -> a -> Bool+allOf :: ((c -> Const All d) -> a -> Const All b) -> (c -> Bool) -> a -> Bool+allOf l f = getAll . foldMapOf l (All . f)+{-# INLINE allOf #-}++productOf :: Num c => ((c -> Const (Product c) d) -> a -> Const (Product c) b) -> a -> c+productOf l = getProduct . foldMapOf l Product+{-# INLINE productOf #-}++sumOf ::  Num c => ((c -> Const (Sum c) d) -> a -> Const (Sum c) b) -> a -> c+sumOf l = getSum . foldMapOf l Sum+{-# INLINE sumOf #-}++-- | > traverseOf_ :: Applicative f => MultiGetter a b -> (b -> f c) -> a -> f ()+traverseOf_ :: Applicative f => ((c -> Const (Traversal f) d) -> a -> Const (Traversal f) b) -> (c -> f e) -> a -> f ()+traverseOf_ l f = getTraversal . foldMapOf l (Traversal . (() <$) . f)+{-# INLINE traverseOf_ #-}++-- | > forOf_ :: Applicative f => MultiGetter a b -> a -> (b -> f c) -> f ()+forOf_ :: Applicative f => ((c -> Const (Traversal f) d) -> a -> Const (Traversal f) b) -> a -> (c -> f e) -> f ()+forOf_ l a f = traverseOf_ l f a+{-# INLINE forOf_ #-}++-- | > sequenceAOf_ :: Applicative f => MultiGetter a (f ()) -> a -> f ()+sequenceAOf_ :: Applicative f => ((f () -> Const (Traversal f) d) -> a -> Const (Traversal f) e) -> a -> f ()+sequenceAOf_ l = getTraversal . foldMapOf l (Traversal . (() <$))+{-# INLINE sequenceAOf_ #-}++-- | > mapMOf_ :: Monad m => MultiGetter a b -> (b -> m c) -> a -> m ()+mapMOf_ :: Monad m => ((c -> Const (Traversal (WrappedMonad m)) d) -> a -> Const (Traversal (WrappedMonad m)) b) -> (c -> m e) -> a -> m ()+mapMOf_ l f = unwrapMonad . traverseOf_ l (WrapMonad . f)+{-# INLINE mapMOf_ #-}++-- | > forMOf_ :: Monad m => MultiGetter a b -> a -> (b -> m c) -> m ()+forMOf_ :: Monad m => ((c -> Const (Traversal (WrappedMonad m)) d) -> a -> Const (Traversal (WrappedMonad m)) b) -> a -> (c -> m e) -> m ()+forMOf_ l a f = mapMOf_ l f a+{-# INLINE forMOf_ #-}++-- | > sequenceOf_ :: Monad m => MultiGetter a (m b) -> a -> m ()+sequenceOf_ :: Monad m => ((m c -> Const (Traversal (WrappedMonad m)) d) -> a -> Const (Traversal (WrappedMonad m)) b) -> a -> m ()+sequenceOf_ l = unwrapMonad . traverseOf_ l WrapMonad+{-# INLINE sequenceOf_ #-}++-- | The sum of a collection of actions, generalizing 'concatOf'.+asumOf :: Alternative f => ((f c -> Const (Endo (f c)) d) -> a -> Const (Endo (f c)) b) -> a -> f c+asumOf l = foldrOf l (<|>) Applicative.empty+{-# INLINE asumOf #-}++-- | The sum of a collection of actions, generalizing 'concatOf'.+msumOf :: MonadPlus m => ((m c -> Const (Endo (m c)) d) -> a -> Const (Endo (m c)) b) -> a -> m c+msumOf l = foldrOf l mplus mzero+{-# INLINE msumOf #-}++elemOf :: Eq c => ((c -> Const Any d) -> a -> Const Any b) -> c -> a -> Bool+elemOf l = anyOf l . (==)+{-# INLINE elemOf #-}++notElemOf :: Eq c => ((c -> Const Any d) -> a -> Const Any b) -> c -> a -> Bool+notElemOf l c = not . elemOf l c+{-# INLINE notElemOf #-}++-- | concatMapOf :: MultiGetter a c -> (c -> [e]) -> a -> [e]+concatMapOf :: ((c -> Const [e] d) -> a -> Const [e] b) -> (c -> [e]) -> a -> [e]+concatMapOf l ces a = getConst  (l (Const . ces) a)+{-# INLINE concatMapOf #-}++concatOf :: (([e] -> Const [e] d) -> a -> Const [e] b) -> a -> [e]+concatOf = reading+{-# INLINE concatOf #-}++--------------------------+-- Multilens combinators+--------------------------++traverseOf :: Applicative f => ((c -> f d) -> a -> f b) -> (c -> f d) -> a -> f b+traverseOf = id+{-# INLINE traverseOf #-}++mapMOf :: Monad m => ((c -> WrappedMonad m d) -> a -> WrappedMonad m b) -> (c -> m d) -> a -> m b+mapMOf l cmd a = unwrapMonad (l (WrapMonad . cmd) a)+{-# INLINE mapMOf #-}++sequenceAOf :: Applicative f => ((f b -> f (f b)) -> a -> f b) -> a -> f b+sequenceAOf l = l pure+{-# INLINE sequenceAOf #-}++sequenceOf :: Monad m => ((m b -> WrappedMonad m (m b)) -> a -> WrappedMonad m b) -> a -> m b+sequenceOf l = unwrapMonad . l pure+{-# INLINE sequenceOf #-}++--------------------------+-- Multigetters+--------------------------++folded :: Foldable f => MultiGetter (f a) a+folded = gettingMany id+{-# INLINE folded #-}++--------------------------+-- Multilenses+--------------------------++-- | This is the partial lens that never succeeds at returning any values+constML :: Applicative f => (c -> f d) -> a -> f a+constML = const pure+{-# INLINE constML #-}++headML :: Applicative f => (a -> f a) -> [a] -> f [a]+headML _ [] = pure []+headML f (a:as) = (:as) <$> f a+{-# INLINE headML #-}++tailML :: Applicative f => ([a] -> f [a]) -> [a] -> f [a]+tailML _ [] = pure []+tailML f (a:as) = (a:) <$> f as+{-# INLINE tailML #-}++leftML :: Applicative f => (a -> f b) -> Either a c -> f (Either b c)+leftML f (Left a)  = Left <$> f a+leftML _ (Right c) = pure $ Right c+{-# INLINE leftML #-}++keyML :: (Applicative f, Ord k) => k -> (v -> f v) -> Map k v -> f (Map k v)+keyML k = keyL k . traverse+{-# INLINE keyML #-}++intKeyML :: Applicative f => Int -> (v -> f v) -> IntMap v -> f (IntMap v)+intKeyML k = intKeyL k . traverse+{-# INLINE intKeyML #-}++elementML :: (Applicative f, Traversable t) => Int -> (a -> f a) -> t a -> f (t a)+elementML j f ta = fst (runSA (traverse go ta) 0) where+  go a = SA $ \i -> (if i == j then f a else pure a, i + 1)+{-# INLINE elementML #-}+ ------------------------------------------------------------------------------+-- Implementation details+------------------------------------------------------------------------------++newtype SA f a = SA { runSA :: Int -> (f a, Int) }++instance Functor f => Functor (SA f) where+  fmap f (SA m) = SA $ \i -> case m i of+    (fa, j) -> (fmap f fa, j)++instance Applicative f => Applicative (SA f) where+  pure a = SA (\i -> (pure a, i))+  SA mf <*> SA ma = SA $ \i -> case mf i of+    (ff, j) -> case ma j of+       (fa, k) -> (ff <*> fa, k)++newtype Traversal f = Traversal { getTraversal :: f () }++instance Applicative f => Monoid (Traversal f) where+  mempty = Traversal (pure ())+  Traversal ma `mappend` Traversal mb = Traversal (ma *> mb)++-- wrapMonadL :: Functor f => (m a -> f (n b)) -> WrappedMonad m a -> f (WrappedMonad n b)+-- wrapMonadL f (WrapMonad ma) = WrapMonad <$> f ma++------------------------------------------------------------------------------ -- Template Haskell ------------------------------------------------------------------------------ @@ -309,7 +672,7 @@   typeInfo          <- extractLensTypeInfo datatype   let derive1 = deriveLens nameTransform typeInfo   constructorFields <- extractConstructorFields datatype-  concat <$> mapM derive1 constructorFields+  Prelude.concat <$> Prelude.mapM derive1 constructorFields  extractLensTypeInfo :: Name -> Q LensTypeInfo extractLensTypeInfo datatype = do@@ -344,7 +707,7 @@   Just lensNameStr -> do     body <- deriveLensBody (mkName lensNameStr) fieldName     return [body]-  where +  where     (fieldName, _fieldStrict, _fieldType) = field     (_tyName, _tyVars) = ty  -- just to clarify what's here
− src/Control/Lens/Multi.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Lens.Multi--- Copyright   :  (C) 2012 Edward Kmett--- License     :  BSD-style (see the file LICENSE)--- Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  portable------ Note: 'traverse' is a 'MultiLensFamily'------------------------------------------------------------------------------module Control.Lens.Multi-  (-  -- * Lenses-    MultiLens-  , MultiLensFamily--  -- * Common lenses-  , constML-  , mapML-  , intMapML-  , headML-  , tailML-  , leftML-  , elementML-  ) where--import Control.Applicative-import Data.IntMap as IntMap-import Data.Map as Map-import Data.Traversable--type MultiLens a b          = forall f. Applicative f => (b -> f b) -> a -> f a-type MultiLensFamily a b c d = forall f. Applicative f => (c -> f d) -> a -> f b--constML :: Applicative f => (a -> f a) -> b -> f b-constML = const pure--headML :: Applicative f => (a -> f a) -> [a] -> f [a]-headML _ [] = pure []-headML f (a:as) = (:as) <$> f a-{-# INLINE headML #-}--tailML :: Applicative f => ([a] -> f [a]) -> [a] -> f [a]-tailML _ [] = pure []-tailML f (a:as) = (a:) <$> f as-{-# INLINE tailML #-}--leftML :: Applicative f => (a -> f b) -> Either a c -> f (Either b c)-leftML f (Left a)  = Left <$> f a-leftML _ (Right c) = pure $ Right c-{-# INLINE leftML #-}--mapML :: (Applicative f, Ord k) => k -> (v -> f v) -> Map k v -> f (Map k v)-mapML k f m = case Map.lookup k m of-  Nothing -> pure m-  Just v -> (\v' -> Map.insert k v' m) <$> f v-{-# INLINE mapML #-}--intMapML :: Applicative f => Int -> (v -> f v) -> IntMap v -> f (IntMap v)-intMapML k f m = case IntMap.lookup k m of-  Nothing -> pure m-  Just v -> (\v' -> IntMap.insert k v' m) <$> f v-{-# INLINE intMapML #-}--newtype SA f a = SA { runSA :: Int -> (f a, Int) }--instance Functor f => Functor (SA f) where-  fmap f (SA m) = SA $ \i -> case m i of-    (fa, j) -> (fmap f fa, j)--instance Applicative f => Applicative (SA f) where-  pure a = SA (\i -> (pure a, i))-  SA mf <*> SA ma = SA $ \i -> case mf i of-    (ff, j) -> case ma j of-       (fa, k) -> (ff <*> fa, k)--elementML :: (Applicative f, Traversable t) => Int -> (a -> f a) -> t a -> f (t a)-elementML j f ta = fst (runSA (traverse go ta) 0) where-  go a = SA $ \i -> (if i == j then f a else pure a, i + 1)
+ src/Control/Lens/Rep.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Lens.Rep+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  RankNTypes+--+-- Corepresentable endofunctors represented by their polymorphic lenses+--+-- The polymorphic lenses of the form @(forall x. Lens (f x) x)@ each+-- represent a distinct path into a functor @f@. If the functor is entirely+-- characterized by assigning values to these paths, then the functor is+-- representable.+--+-- Consider the following example.+--+-- > import Control.Lens+-- > import Control.Lens.Rep+-- > import Data.Distributive+--+-- > data Pair a = Pair { _x :: a, _y :: a }+--+-- > makeLenses ''Pair+--+-- > instance Representable Pair where+-- >   rep f = Pair (f x) (f y)+--+-- From there, you can get definitions for a number of instances for free.+--+-- > instance Applicative Pair where+-- >   pure  = pureRep+-- >   (<*>) = apRep+--+-- > instance Monad Pair where+-- >   return = pureRep+-- >   (>>=) = bindRep+--+-- > instance Distributive Pair where+-- >   distribute = distributeRep+--+----------------------------------------------------------------------------+module Control.Lens.Rep+  (+  -- * Representable Functors+    Representable(..)+  -- * Using Lenses as Representations+  , Rep+  -- * Default definitions+  , fmapRep+  , pureRep+  , apRep+  , bindRep+  , distributeRep+  -- * Wrapped Representations+  , Key(..)+  , keys+  -- * Traversal with representation+  , mapWithRep+  , foldMapWithRep+  , foldrWithRep+  , traverseWithRep+  , traverseWithRep_+  , forWithRep+  , mapMWithRep+  , mapMWithRep_+  , forMWithRep+  ) where++import Control.Applicative+import Control.Lens+import Data.Foldable         as Foldable+import Data.Functor.Identity+import Data.Monoid+import Data.Traversable      as Traversable++-- | The representation of a 'Representable' 'Functor' as Lenses+type Rep f = forall a. Lens (f a) a++-- | Representable Functors.+--+-- A 'Functor' @f@ is 'Representable' if it is isomorphic to @(x -> a)@+-- for some x. All such functors can be represented by choosing @x@ to be+-- the set of lenses that are polymorphic in the contents of the 'Functor',+-- that is to say @x = Rep f@ is a valid choice of 'x' for every +-- 'Representable' 'Functor'.+--+-- Note: Some sources refer to covariant representable functors as+-- corepresentable functors, and leave the \"representable\" name to+-- contravariant functors (those are isomorphic to @(a -> x)@ for some @x@).+--+-- As the covariant case is vastly more common, and both are often referred to+-- as representable functors, we choose to call these functors 'Representable'+-- here.++class Functor f => Representable f where+  rep :: (Rep f -> a) -> f a++instance Representable Identity where+  rep f = Identity (f identityL)++-- | NB: The Eq requirement on this instance is a consequence of a lens+-- rather than 'e' as the representation.+instance Eq e => Representable ((->) e) where+  rep f e = f (atL e)++-- | 'fmapRep' is a valid default definition for 'fmap' for a representable+-- functor.+--+-- > fmapRep f m = rep $ \i -> f (m^.i)+--+-- Usage for a representable functor @Foo@:+--+-- > instance Functor Foo where+-- >   fmap = fmapRep++fmapRep :: Representable f => (a -> b) -> f a -> f b+fmapRep f m = rep $ \i -> f (m^.i)+{-# INLINE fmapRep #-}++-- | 'pureRep' is a valid default definition for 'pure' and 'return' for a+-- representable functor.+--+-- > pureRep = rep . const+--+-- Usage for a representable functor @Foo@:+--+-- > instance Applicative Foo where+-- >    pure = pureRep+-- >    (<*>) = apRep+--+-- > instance Monad Foo where+-- >   return = pureRep+-- >   (>>=) = bindRep+pureRep :: Representable f => a -> f a+pureRep = rep . const+{-# INLINE pureRep #-}++-- | 'apRep' is a valid default definition for '(<*>)' for a representable+-- functor.+--+-- > apRep mf ma = rep $ \i -> mf^.i $ ma^.i+--+-- Usage for a representable functor @Foo@:+--+-- > instance Applicative Foo where+-- >    pure = pureRep+-- >   (<*>) = apRep+apRep :: Representable f => f (a -> b) -> f a -> f b+apRep mf ma = rep $ \i -> mf^.i $ ma^.i+{-# INLINE apRep #-}++-- | 'bindRep' is a valid default default definition for '(>>=)' for a+-- representable functor.+--+-- > bindRep m f = rep $ \i -> f(m^.i)^.i+--+-- Usage for a representable functor @Foo@:+--+-- > instance Monad ... where+-- >   return = pureRep+-- >   (>>=) = bindRep+bindRep :: Representable f => f a -> (a -> f b) -> f b+bindRep m f = rep $ \i -> f(m^.i)^.i+{-# INLINE bindRep #-}++-- | A default definition for 'Data.Distributive.distribute' for a 'Representable' 'Functor'+--+-- > distributeRep wf = rep $ \i -> fmap (^.i) wf+--+-- Typical Usage:+--+-- > instance Distributive ... where+-- >   distribute = distributeRep+distributeRep :: (Representable f, Functor w) => w (f a) -> f (w a)+distributeRep wf = rep $ \i -> fmap (^.i) wf+{-# INLINE distributeRep #-}++-----------------------------------------------------------------------------+-- Keys+-----------------------------------------------------------------------------++-- | Sometimes you need to store a path lens into a container, but at least+-- at this time, impredicative polymorphism in GHC is somewhat lacking.+--+-- This type provides a way to, say, store a list of polymorphic lenses.+newtype Key f = Key { turn :: Rep f }++-- | A 'Representable' 'Functor' has a fixed shape. This fills each position +-- in it with a 'Key'+keys :: Representable f => f (Key f)+keys = rep Key+{-# INLINE keys #-}++-----------------------------------------------------------------------------+-- Traversal+-----------------------------------------------------------------------------+++-- | Map over a 'Representable' 'Functor' with access to the lens for the +-- current position+--+-- > mapWithKey f m = rep $ \i -> f i (m^.i)+mapWithRep :: Representable f => (Rep f -> a -> b) -> f a -> f b+mapWithRep f m = rep $ \i -> f i (m^.i)+{-# INLINE mapWithRep #-}++-- | Traverse a 'Representable' 'Functor' with access to the current path+traverseWithRep :: (Representable f, Traversable f, Applicative g)+                => (Rep f -> a -> g b) -> f a -> g (f b)+traverseWithRep f m = sequenceA (mapWithRep f m)+{-# INLINE traverseWithRep #-}++-- | Traverse a 'Representable' 'Functor' with access to the current path+-- as a lens, discarding the result+traverseWithRep_ :: (Representable f, Foldable f, Applicative g)+                 => (Rep f -> a -> g b) -> f a -> g ()+traverseWithRep_ f m = sequenceA_ (mapWithRep f m)+{-# INLINE traverseWithRep_ #-}++-- | Traverse a 'Representable' 'Functor' with access to the current path+-- and a lens (and the arguments flipped)+forWithRep :: (Representable f, Traversable f, Applicative g)+                => f a -> (Rep f -> a -> g b) -> g (f b)+forWithRep m f = sequenceA (mapWithRep f m)+{-# INLINE forWithRep #-}++-- | 'mapM' over a 'Representable' 'Functor' with access to the current path+-- as a lens+mapMWithRep :: (Representable f, Traversable f, Monad m)+                => (Rep f -> a -> m b) -> f a -> m (f b)+mapMWithRep f m = Traversable.sequence (mapWithRep f m)+{-# INLINE mapMWithRep #-}++-- | 'mapM' over a 'Representable' 'Functor' with access to the current path+-- as a lens, discarding the result+mapMWithRep_ :: (Representable f, Foldable f, Monad m)+                 => (Rep f -> a -> m b) -> f a -> m ()+mapMWithRep_ f m = Foldable.sequence_ (mapWithRep f m)+{-# INLINE mapMWithRep_ #-}++-- | 'mapM' over a 'Representable' 'Functor' with access to the current path+-- as a lens (with the arguments flipped)+forMWithRep :: (Representable f, Traversable f, Monad m)+                => f a -> (Rep f -> a -> m b) -> m (f b)+forMWithRep m f = Traversable.sequence (mapWithRep f m)+{-# INLINE forMWithRep #-}++-- | Fold over a 'Representable' 'Functor' with access to the current path+-- as a lens, yielding a 'Monoid'+foldMapWithRep :: (Representable f, Foldable f, Monoid m)+               => (Rep f -> a -> m) -> f a -> m+foldMapWithRep f m = fold (mapWithRep f m)+{-# INLINE foldMapWithRep #-}++-- | Fold over a 'Representable' 'Functor' with access to the current path+-- as a lens.+foldrWithRep :: (Representable f, Foldable f) => (Rep f -> a -> b -> b) -> b -> f a -> b+foldrWithRep f b m = Foldable.foldr id b (mapWithRep f m)+{-# INLINE foldrWithRep #-}+