lens 0.3 → 0.4
raw patch · 4 files changed
+661/−426 lines, 4 filesdep +bytestringdep ~base
Dependencies added: bytestring
Dependency ranges changed: base
Files
- lens.cabal +8/−2
- src/Control/Lens.hs +516/−421
- src/Control/Lens/Rep.hs +4/−3
- src/Control/Lens/TH.hs +133/−0
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses-version: 0.3+version: 0.4 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -23,13 +23,19 @@ exposed-modules: Control.Lens Control.Lens.Rep+ Control.Lens.TH ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields hs-source-dirs: src build-depends: base == 4.*,+ bytestring == 0.9.*, 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+ Rank2Types+ RankNTypes+ Safe+ TemplateHaskell+ Trustworthy
src/Control/Lens.hs view
@@ -1,14 +1,12 @@-{-# LANGUAGE RankNTypes, TemplateHaskell #-}-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE Rank2Types, Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens -- Copyright : (C) 2012 Edward Kmett--- (C) 2012 Dan Burton -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional--- Portability : RankNTypes, TemplateHaskell+-- Portability : Rank2Types -- -- This package provides lenses that are compatible with other van -- Laarhoven lens libraries, while reducing the complexty of the imports.@@ -26,98 +24,122 @@ -- 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+-- getters, traversals, folds, and traversal families in such -- a way that they can all be composed automatically with @(.)@. --+-- You can derive lenses automatically for many data types:+--+-- > import Control.Lens.TH+-- > data Foo a = Foo { _fooArgs :: [String], _fooValue :: a }+-- > makeLenses ''Foo+--+-- This defines the following lenses:+--+-- > fooArgs :: Lens (Foo a) [String]+-- > fooValue :: LensFamily (Foo a) (Foo b) a b+-- ---------------------------------------------------------------------------- module Control.Lens ( -- * Lenses Lens , LensFamily- , Getter- , Setter- , SetterFamily- , MultiLens- , MultiLensFamily - -- * Constructing Lenses- , makeLenses- , makeLensesBy- , makeLensesFor+ -- ** Constructing Lenses , lens , iso , clone++ -- * Getters+ , Getter, GetterFamily , getting- , gettingMany- , setting - -- * Manipulating Values+ -- ** Getting Values , reading+ , (^.), (^$)++ -- * Setters+ , Setter, SetterFamily+ , setting++ -- ** Setting Values , modifying , writing- , (^.), (^$) , (^%=), (^=), (^+=), (^-=), (^*=), (^/=), (^||=), (^&&=) -- * Manipulating State , access+ , (%=), (~=), (+=), (-=), (*=), (//=), (||=), (&&=)+ , (%%=) , Focus(..)- , (%=), (~=), (%%=), (+=), (-=), (*=), (//=), (||=), (&&=) - -- * Lenses and LensFamilies- , fstL- , sndL- , keyL- , intKeyL- , memberL- , intMemberL- , identityL- , atL+ -- * Folds+ , Fold+ , FoldFamily - -- * MultiGetters+ -- ** Common Folds , folded+ , folding - -- ** MultiGetterFamily Combinators- , mapOf+ -- ** Fold Combinators , foldMapOf , foldrOf , foldOf , toListOf- , anyOf, allOf- , andOf, orOf- , productOf, sumOf+ , anyOf+ , allOf+ , andOf+ , orOf+ , productOf+ , sumOf , traverseOf_ , forOf_ , sequenceAOf_ , mapMOf_ , forMOf_ , sequenceOf_- , asumOf, msumOf+ , asumOf+ , msumOf , concatMapOf , concatOf , elemOf , notElemOf - -- * MultiLenses- , constML- , keyML- , intKeyML- , headML- , tailML- , leftML- , rightML- , elementML+ -- * Traversals+ , Traversal+ , TraversalFamily - -- ** MultiLens Combinators+ -- ** Common Traversals+ , traverseNothing+ , traverseValueAt+ , traverseValueAtInt+ , traverseHead+ , traverseTail+ , traverseLeft+ , traverseRight+ , traverseElement+ , TraverseByteString(..)++ -- ** Traversal Combinators , traverseOf , mapMOf , sequenceAOf , sequenceOf + -- ** Common Lenses+ , _1+ , _2+ , valueAt+ , valueAtInt+ , contains+ , containsInt+ , identity+ , resultAt+ -- * Implementation details , IndexedStore , Focusing- , Traversal+ , Traversed ) where import Control.Applicative as Applicative@@ -126,7 +148,8 @@ 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.ByteString.Lazy as Lazy+import Data.ByteString as Strict import Data.Foldable as Foldable import Data.Functor.Identity import Data.IntMap as IntMap@@ -135,15 +158,19 @@ import Data.Monoid import Data.Set as Set import Data.Traversable-import Language.Haskell.TH+import Data.Word (Word8) infixl 8 ^. infixr 4 ^%=, ^=, ^+=, ^*=, ^-=, ^/=, ^&&=, ^||= infix 4 ~=, %=, %%=, +=, -=, *=, //=, &&=, ||= infixr 0 ^$ +--------------------------+-- Lenses+--------------------------+ -- |--- A Lens is a purely functional reference to part of a data structure, it can be used to read or write to that part of the whole.+-- A Lens is a purely functional reference to part of a data structure. It can be used to read or write to that part of the whole. -- -- With great power comes great responsibility, and a 'Lens' is subject to the lens laws: --@@ -151,14 +178,21 @@ -- > writing l (reading l a) a = a -- > writing l c (writing l b a) = writing l c a ----- Every 'Lens' can be used directly as a 'LensFamily' or as a 'Getter', 'Setter', or 'MultiLens', which transitively mens it can be used as--- almost anything! Such as a 'MultiLensFamily', a 'GetterFamily', a 'MultiGetterFamily', a 'MultiGetter', or a 'SetterFamily'.+-- Every 'Lens' can be used directly as a 'LensFamily' or as a 'Getter', 'Setter', or 'Traversal', which transitively mens it can be used as+-- almost anything! Such as a 'TraversalFamily', a 'GetterFamily', a 'FoldFamily', a 'Fold', or a 'SetterFamily'. ----- > type Lens a b = LensFamily a a b b --+-- Example:+--+-- > import Data.Complex+-- > imaginary :: Lens (Complex a) a+-- > imaginary f (e :+ i) = (e :+) <$> f i+--+-- > type Lens a b = LensFamily a a b b+ type Lens a b = forall f. Functor f => (b -> f b) -> a -> f a --- | A LensFamily is a more general form of a Lens that permits polymorphic field updates+-- | A 'LensFamily' is a more general form of a 'Lens' that permits polymorphic field updates -- -- With great power comes great responsibility, and a 'LensFamily' is subject to the lens laws: --@@ -166,74 +200,24 @@ -- > writing l (reading l a) a = a -- > writing l c (writing l b a) = writing l c a ----- These laws are strong enough that the 4 type parameters of a LensFamily cannot vary fully independently. For more on+-- These laws are strong enough that the 4 type parameters of a 'LensFamily' cannot vary fully independently. For more on -- how they interact, read the "Why is it a Lens Family?" section of <http://comonad.com/reader/2012/mirrored-lenses/>. ----- Every 'LensFamily' can be used as a 'GetterFamily', a 'SetterFamily' or a 'MultiLensFamily', which transitively means it can be--- used as a 'MultiGetterFamily'.+-- Every 'LensFamily' can be used as a 'GetterFamily', a 'SetterFamily' or a 'TraversalFamily', which transitively means it can be+-- used as a 'FoldFamily'. ----- Despite the complicated signature the pattern for implementing a 'LensFamily' is the same as a Lens.+-- Despite the complicated signature the pattern for implementing a 'LensFamily' is the same as a 'Lens'. -- in fact the implementation doesn't change, the type signature merely generalizes. ----- > sndL :: LensFamily (c,a) (c,b) a b--- > sndL f (a,c) = (,) a <$> f c+-- > identity :: LensFamily (Identity a) (Identity b) a b+-- > identity f (Identity a) = Identity <$> f a type LensFamily a b c d = forall f. Functor f => (c -> f d) -> a -> f b --- | A 'SetterFamily' describes a way to perform polymorphic update to potentially multiple fields in a way that can be--- composed with other lens-like constructions that can be used as a 'SetterFamily'.------ The typical way to obtain a 'SetterFamily' is to build one with 'setting' or to compose some other lens-like construction--- with a 'SetterFamily'.------ Note: the only lens law that applies to a 'SetterFamily' is------ > writing l c (writing l b a) = writing l c a------ since 'reading' a SetterFamily doesn't work, so the other two laws can never be invoked.-type SetterFamily a b c d = (c -> Identity d) -> a -> Identity b---- | Every 'Setter' can be used directly as a 'SetterFamily'.------ > type Setter a b = SetterFamily a a b b-type Setter a b = (b -> Identity b) -> a -> Identity a---- | A 'MultiGetterFamily' describes how to retrieve multiple values in a way that can be composed--- with other lens-like constructions.------ A 'MultiGetterFamily a b c d' provides a structure with operations very similar to those of the 'Foldable'--- typeclass, see 'foldMapOf' and the other MultiGetterFamily combinators.----type MultiGetterFamily a b c d = forall m. Monoid m => (c -> Const m d) -> a -> Const m b---- | Every 'MultiGetter' can be used directly as a 'MultiGetterFamily'.--------- > type MultiGetter a b = MultiGetterFamily a b c d-type MultiGetter a b = forall m. Monoid m => (b -> Const m b)-> a -> Const m a---- | A 'GetterFamily' describes how to retrieve a single value in a way that can be composed with--- other lens-like constructions. It can be used directly as a 'MultiGetterFamily', since it just--- ignores the 'Monoid'.-type GetterFamily a b c d = forall z. (c -> Const z d) -> a -> Const z b---- | A 'Getter' can be used directly as a 'GetterFamily' or as a 'MultiGetter', and hence it can be as a 'MutliGetterFamily'.------ In general while your combinators may produce a 'Getter' it is better to consume any 'GetterFamily'.------ > type Getter a b = GetterFamily a a b b-type Getter a b = forall z. (b -> Const z b) -> a -> Const z a---- | A 'MultiLensFamily' can be used directly as a 'SetterFamily' or a 'MultiGetterFamily' and provides--- the ability to both read and update multiple fields, subject to the (relatively weak) MultiLensFamily laws.-type MultiLensFamily a b c d = forall f. Applicative f => (c -> f d) -> a -> f b---- | Every 'MultiLens' can be used as a 'MultiLensFamily' or a 'Setter' or 'MultiGetter', so it can transitively be used as a--- 'MultiGetterFamily' or 'SetterFamily' as well.------ > type MultiLens a b = MultiLensFamily a a b b-type MultiLens a b = forall f. Applicative f => (b -> f b) -> a -> f a+--------------------------+-- Constructing Lenses+-------------------------- --- | Build a 'Lens' or 'LensFamily' from a getter and a setter+-- | Build a 'Lens' or 'LensFamily' from a getter and a setter. -- -- > lens :: Functor f => (a -> c) -> (d -> a -> b) -> (c -> f d) -> a -> f b lens :: (a -> c) -> (d -> a -> b) -> LensFamily a b c d@@ -247,45 +231,40 @@ iso f g h a = g <$> h (f a ) {-# INLINE iso #-} --- | Build a Getter or GetterFamily+---------------+-- Getters+---------------++-- | A 'Getter' can be used directly as a 'GetterFamily' or as a 'Fold', and hence it can be as a 'FoldFamily'.+--+-- In general while your combinators may produce a 'Getter' it is better to consume any 'GetterFamily'.+--+-- > type Getter a b = GetterFamily a a b b+type Getter a b = forall z. (b -> Const z b) -> a -> Const z a++-- | A 'GetterFamily' describes how to retrieve a single value in a way that can be composed with+-- other lens-like constructions. It can be used directly as a 'FoldFamily', since it just+-- ignores the 'Monoid'.+type GetterFamily a b c d = forall z. (c -> Const z d) -> a -> Const z b++-- | Build a 'Getter' or 'GetterFamily' getting :: (a -> c) -> GetterFamily a b c d getting f g a = Const (getConst (g (f a))) {-# INLINE getting #-} --- | Building a MultiGetter or MultiGetterFamily-gettingMany :: Foldable f => (a -> f c) -> MultiGetterFamily a b c d-gettingMany f g a = Const (foldMap (getConst . g) (f a))-{-# INLINE gettingMany #-}---- | Build a Setter or SetterFamily-setting :: ((c -> d) -> a -> b) -> SetterFamily a b c d-setting f g a = Identity (f (runIdentity . g) a)-{-# INLINE setting #-}----------------------------------------------------------------------------------- Using Lenses-------------------------------------------------------------------------------+-------------------------------+-- Getting Values+------------------------------- -- | Get the value of a 'Getter', 'Lens' or 'LensFamily' or the fold of a--- 'MultiGetter', 'MultiLens' or 'MultiLensFamily' that points at monoidal+-- 'Fold', 'Traversal' or 'TraversalFamily' that points at monoidal -- values.+--+-- > reading :: GetterFamily a b c d -> a -> c reading :: ((c -> Const c d) -> a -> Const c b) -> a -> c reading l a = getConst (l Const a) {-# INLINE reading #-} --- | 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 #-}---- | 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@@ -296,160 +275,225 @@ -- 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+-- > ghci> ((0, 1 :+ 2), 3)^._1._2.getting magnitude -- > 2.23606797749979 (^.) :: a -> ((c -> Const c d) -> a -> Const c b) -> c a ^. l = getConst (l Const a) {-# INLINE (^.) #-} +------------------------------------------------------------------------------+-- Setters+------------------------------------------------------------------------------++-- | Every 'Setter' can be used directly as a 'SetterFamily'.+--+-- Note: the only lens law that applies to a 'Setter' is+--+-- > writing l c (writing l b a) = writing l c a+--+-- 'reading' a 'Setter' doesn't work in general, so the other two laws can never be invoked.+--+-- > type Setter a b = SetterFamily a a b b+type Setter a b = (b -> Identity b) -> a -> Identity a++-- | A 'SetterFamily' describes a way to perform polymorphic update to potentially multiple fields in a way that can be+-- composed with other lens-like constructions that can be used as a 'SetterFamily'.+--+-- The typical way to obtain a 'SetterFamily' is to build one with 'setting' or to compose some other 'Lens'-like construction+-- with a 'SetterFamily'.+--+-- Note: the only lens law that applies to a 'SetterFamily' is+--+-- > writing l c (writing l b a) = writing l c a+--+-- 'reading' a 'SetterFamily' doesn't work in general, so the other two laws can never be invoked.+type SetterFamily a b c d = (c -> Identity d) -> a -> Identity b++-- | Build a Setter or SetterFamily+--+-- > setting . modifying = id+-- > modifying . setting = id+--+setting :: ((c -> d) -> a -> b) -> SetterFamily a b c d+setting f g a = Identity (f (runIdentity . g) a)+{-# INLINE setting #-}++-- | Modify the target of a 'Lens', 'LensFamily' or all the targets of a+-- 'Traversal', 'TraversalFamily', 'Setter' or 'SetterFamily'+--+-- > fmap = modifying traverse+-- > setting . modifying = id+-- > modifying . setting = id+--+-- > modifying :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b++modifying :: SetterFamily a b c d -> (c -> d) -> a -> b+modifying l f a = runIdentity (l (Identity . f) a)+{-# INLINE modifying #-}++-- | Replace the target of a 'Lens', 'LensFamily', 'Setter' or 'SetterFamily'+--+-- > (<$) = writing traverse+--+-- > writing :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b+writing :: SetterFamily a b c d -> d -> a -> b+writing l d a = runIdentity (l (\_ -> Identity d) a)+{-# INLINE writing #-}+ -- | 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+-- This is an infix version of 'modifying'+--+-- > fmap f = traverse ^%= f+--+-- > (^%=) :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b+(^%=) :: SetterFamily a b c d -> (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+--+-- > f <$ a = traverse ^= f $ a+--+-- > (^=) :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b+(^=) :: SetterFamily a b c d -> 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)+-- > ghci> _1 ^+= 1 $ (1,2) -- > (2,2)-(^+=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^+= n = mapOf l (+ n)+--+-- > (^+=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a+(^+=) :: Num c => Setter a c -> c -> a -> a+l ^+= n = modifying l (+ n) {-# INLINE (^+=) #-} -- | Multiply the target(s) of a numerically valued 'Lens' or Setter' ----- > ghci> sndL ^*= 4 $ (1,2)+-- > ghci> _2 ^*= 4 $ (1,2) -- > (1,8)-(^*=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^-= n = mapOf l (`subtract` n)-{-# INLINE (^-=) #-}+--+-- > (^*=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a+(^*=) :: Num c => Setter a c -> c -> a -> a+l ^*= n = modifying l (* n)+{-# INLINE (^*=) #-} -- | Decrement the target(s) of a numerically valued 'Lens' or 'Setter' ----- > ghci> fstL ^-= 2 $ (1,2)+-- > ghci> _1 ^-= 2 $ (1,2) -- > (-1,2)-(^-=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a-l ^*= n = mapOf l (* n)-{-# INLINE (^*=) #-}+--+-- > (^-=) :: ((c -> Identity c) -> a -> Identity a) -> c -> a -> a+(^-=) :: Num c => Setter a c -> c -> a -> a+l ^-= n = modifying l (subtract 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 = mapOf l (/ n)+-- | Divide the target(s) of a numerically valued 'Setter'+--+-- > (^/=) :: Fractional c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a+(^/=) :: Fractional b => Setter a b -> b -> a -> a+l ^/= n = modifying l (/ n) -- | Logically '||' the target(s) of a 'Bool'-valued 'Lens' or 'Setter'-(^||=):: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a-l ^||= n = mapOf l (|| n)+--+-- > (^||=):: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a+(^||=):: Setter a Bool -> Bool -> a -> a+l ^||= n = modifying 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 = mapOf l (&& n)+-- (^&&=) :: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a+(^&&=) :: Setter a Bool -> Bool -> a -> a+l ^&&= n = modifying l (&& n) {-# INLINE (^&&=) #-} --------------------------------------------------------------------------------- Cloning Lenses---------------------------------------------------------------------------------data IndexedStore c d a = IndexedStore (d -> a) c--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-{-# INLINE clone #-}-------------------------------------------------------------------------------- -- Common Lenses ------------------------------------------------------------------------------ -- | This is a lens family that can change the value (and type) of the first field of -- a pair. --- > ghci> (1,2)^.fstL+-- > ghci> (1,2)^._1 -- > 1 ----- > ghci> fstL ^= "hello" $ (1,2)+-- > ghci> _1 ^= "hello" $ (1,2) -- > ("hello",2)-fstL :: LensFamily (a,c) (b,c) a b-fstL f (a,c) = (\b -> (b,c)) <$> f a-{-# INLINE fstL #-}+--+-- > anyOf _2 :: (c -> Bool) -> (a, c) -> Bool+-- > traverse._2 :: (Applicative f, Traversable t) => (a -> f b) -> t (c, a) -> f (t (c, b))+-- > foldMapOf (traverse._2) :: (Traversable t, Monoid m) => (c -> m) -> t (b, c) -> m+_1 :: LensFamily (a,c) (b,c) a b+_1 f (a,c) = (\b -> (b,c)) <$> f a+{-# INLINE _1 #-} --- | 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 #-}+-- | As '_1', but for the second field of a pair.+_2 :: LensFamily (c,a) (c,b) a b+_2 f (c,a) = (,) c <$> f a+{-# INLINE _2 #-} -- | This lens can be used to read, write or delete a member of a 'Map'. ----- > ghci> Map.fromList [("hello",12)] ^. keyL "hello"+-- > ghci> Map.fromList [("hello",12)] ^. valueAt "hello" -- > Just 12-keyL :: Ord k => k -> Lens (Map k v) (Maybe v)-keyL k f m = go <$> f (Map.lookup k m) where+valueAt :: Ord k => k -> Lens (Map k v) (Maybe v)+valueAt 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 keyL #-}+{-# INLINE valueAt #-} -- | This lens can be used to read, write or delete a member of an 'IntMap'. ----- > ghci> IntMap.fromList [(1,"hello")] ^. keyL 1+-- > ghci> IntMap.fromList [(1,"hello")] ^. valueAt 1 -- > Just "hello" ----- > ghci> keyL 2 ^= "goodbye" $ IntMap.fromList [(1,"hello")]+-- > ghci> valueAt 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+valueAtInt :: Int -> Lens (IntMap v) (Maybe v)+valueAtInt 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 intKeyL #-}+{-# INLINE valueAtInt #-} -- | 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]+-- > ghci> contains 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+contains :: Ord k => k -> Lens (Set k) Bool+contains k f s = go <$> f (Set.member k s) where go False = Set.delete k s go True = Set.insert k s-{-# INLINE memberL #-}+{-# INLINE contains #-} -- | 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]+-- > ghci> containsInt 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+containsInt :: Int -> Lens IntSet Bool+containsInt k f s = go <$> f (IntSet.member k s) where go False = IntSet.delete k s go True = IntSet.insert k s-{-# INLINE intMemberL #-}+{-# INLINE containsInt #-} -- | 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 #-}+identity :: LensFamily (Identity a) (Identity b) a b+identity f (Identity a) = Identity <$> f a+{-# INLINE identity #-} -- | 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+resultAt :: Eq e => e -> Lens (e -> a) a+resultAt e afa ea = go <$> afa a where a = ea e go a' e' | e == e' = a' | otherwise = a-{-# INLINE atL #-}+{-# INLINE resultAt #-} ------------------------------------------------------------------------------ -- State@@ -490,21 +534,21 @@ focus l (ReaderT m) = ReaderT $ \a -> liftM undefined $ unfocusing $ l (\b -> Focusing $ (\c -> (c,b)) `liftM` m b) a {-# INLINE focus #-} +-- | 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 (%%=) #-}+ -- | Set the value of a field in our monadic state (~=) :: MonadState a m => Setter a b -> b -> m ()-l ~= b = modify (l ^= b)+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)+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@@ -536,221 +580,381 @@ {-# INLINE (||=) #-} ----------------------------- Multigetter combinators+-- Folds --------------------------+-- | Every 'Fold' can be used directly as a 'FoldFamily' (and you should probably be using a 'FoldFamily'+-- instead.)+--+-- > type Fold a b = FoldFamily a b c d+type Fold a b = forall m. Monoid m => (b -> Const m b)-> a -> Const m a --- | > foldMapOf :: Monoid m => MultiGetterFamily a b c d -> (c -> m) -> a -> m+-- | A 'FoldFamily' describes how to retrieve multiple values in a way that can be composed+-- with other lens-like constructions.+--+-- A @'FoldFamily' a b c d@ provides a structure with operations very similar to those of the 'Foldable'+-- typeclass, see 'foldMapOf' and the other 'FoldFamily' combinators.+--+-- By convention, if there exists a 'foo' method that expects a @'Foldable' (f c)@, then there should be a+-- 'fooOf' method that takes a @'FoldFamily' a b c d@ and a value of type @a@.+--+type FoldFamily a b c d = forall m. Monoid m => (c -> Const m d) -> a -> Const m b++-- | Obtain a 'FoldFamily' from any 'Foldable'+folded :: Foldable f => FoldFamily (f c) b c d+folded = folding id+{-# INLINE folded #-}++-- | Building a FoldFamily+folding :: Foldable f => (a -> f c) -> FoldFamily a b c d+folding f g a = Const (foldMap (getConst . g) (f a))+{-# INLINE folding #-}++--------------------------+-- Fold combinators+--------------------------++-- |+-- > foldMap = foldMapOf folded+--+-- > foldMapOf :: Monoid m => FoldFamily a b c d -> (c -> 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 => MultiGetterFamily a b m d -> a -> m+-- |+-- > fold = foldOf folded+--+-- > foldOf :: Monoid m => FoldFamily a b m d -> a -> m foldOf :: Monoid m => ((m -> Const m d) -> a -> Const m b) -> a -> m foldOf l = getConst . l Const {-# INLINE foldOf #-} --- | > foldrOf :: MultiGetterFamily a b c d -> (c -> e -> e) -> e -> a -> e+-- |+-- > foldr = foldrOf folded+--+-- > foldrOf :: FoldFamily a b c d -> (c -> e -> e) -> e -> a -> e 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 :: MultiGetterFamily a b c d -> a -> [c]+-- |+-- > toList = toListOf folded+--+-- > toListOf :: FoldFamily a b c d -> a -> [c] toListOf :: ((c -> Const [c] d) -> a -> Const [c] b) -> a -> [c] toListOf l = foldMapOf l return {-# INLINE toListOf #-} --- | > andOf :: MultiGetterFamily a b Bool d -> a -> Bool+-- |+-- > and = andOf folded+--+-- > andOf :: FoldFamily a b Bool d -> a -> Bool andOf :: ((Bool -> Const All d) -> a -> Const All b) -> a -> Bool andOf l = getAll . foldMapOf l All {-# INLINE andOf #-} --- | > orOf :: MultiGetterFamily a b Bool d -> a -> Bool+-- |+-- > or = orOf folded+--+-- > orOf :: FoldFamily a b Bool d -> a -> Bool orOf :: ((Bool -> Const Any d) -> a -> Const Any b) -> a -> Bool orOf l = getAny . foldMapOf l Any {-# INLINE orOf #-} --- | > anyOf :: MultiGetterFamily a b c d -> (c -> Bool) -> a -> Bool+-- |+-- > any = anyOf folded+--+-- > anyOf :: FoldFamily a b c d -> (c -> 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 :: MultiGetterFamily a b c d -> (c -> Bool) -> a -> Bool+-- |+-- > all = allOf folded+--+-- > allOf :: FoldFamily a b c d -> (c -> 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 => MultiGetterFamily a b c d -> a -> c+-- |+-- > product = productOf folded+--+-- > productOf :: Num c => FoldFamily a b c d -> a -> c 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 => MultiGetterFamily a b c d -> a -> c+-- |+-- > sum = sumOf folded+--+-- > sumOf :: Num c => FoldFamily a b c d -> a -> c 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 => MultiGetterFamily a b c d -> (c -> f e) -> 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)+-- |+-- > traverse_ = traverseOf_ folded+--+-- > traverseOf_ :: Applicative f => FoldFamily a b c d -> (c -> f e) -> a -> f ()+traverseOf_ :: Applicative f => ((c -> Const (Traversed f) d) -> a -> Const (Traversed f) b) -> (c -> f e) -> a -> f ()+traverseOf_ l f = getTraversed . foldMapOf l (Traversed . (() <$) . f) {-# INLINE traverseOf_ #-} --- | > forOf_ :: Applicative f => MultiGetterFamily a b c d -> a -> (c -> f e) -> f ()-forOf_ :: Applicative f => ((c -> Const (Traversal f) d) -> a -> Const (Traversal f) b) -> a -> (c -> f e) -> f ()+-- |+-- > for_ = forOf_ folded+--+-- > forOf_ :: Applicative f => FoldFamily a b c d -> a -> (c -> f e) -> f ()+forOf_ :: Applicative f => ((c -> Const (Traversed f) d) -> a -> Const (Traversed f) b) -> a -> (c -> f e) -> f () forOf_ l a f = traverseOf_ l f a {-# INLINE forOf_ #-} --- | > sequenceAOf_ :: Applicative f => MultiGetterFamily a b (f ()) d -> a -> f ()-sequenceAOf_ :: Applicative f => ((f () -> Const (Traversal f) d) -> a -> Const (Traversal f) b) -> a -> f ()-sequenceAOf_ l = getTraversal . foldMapOf l (Traversal . (() <$))+-- |+-- > sequenceA_ = sequenceAOf_ folded+--+-- > sequenceAOf_ :: Applicative f => FoldFamily a b (f ()) d -> a -> f ()+sequenceAOf_ :: Applicative f => ((f () -> Const (Traversed f) d) -> a -> Const (Traversed f) b) -> a -> f ()+sequenceAOf_ l = getTraversed . foldMapOf l (Traversed . (() <$)) {-# INLINE sequenceAOf_ #-} --- | > mapMOf_ :: Monad m => MultiGetterFamily a b c d -> (c -> m e) -> a -> m ()-mapMOf_ :: Monad m => ((c -> Const (Traversal (WrappedMonad m)) d) -> a -> Const (Traversal (WrappedMonad m)) b) -> (c -> m e) -> a -> m ()+-- |+-- > mapM_ = mapMOf_ folded+--+-- > mapMOf_ :: Monad m => FoldFamily a b c d -> (c -> m e) -> a -> m ()+mapMOf_ :: Monad m => ((c -> Const (Traversed (WrappedMonad m)) d) -> a -> Const (Traversed (WrappedMonad m)) b) -> (c -> m e) -> a -> m () mapMOf_ l f = unwrapMonad . traverseOf_ l (WrapMonad . f) {-# INLINE mapMOf_ #-} --- | > forMOf_ :: Monad m => MultiGetterFamily a b c d -> a -> (c -> m e) -> m ()-forMOf_ :: Monad m => ((c -> Const (Traversal (WrappedMonad m)) d) -> a -> Const (Traversal (WrappedMonad m)) b) -> a -> (c -> m e) -> m ()+-- |+-- > forM_ = forMOf_ folded+--+-- > forMOf_ :: Monad m => FoldFamily a b c d -> a -> (c -> m e) -> m ()+forMOf_ :: Monad m => ((c -> Const (Traversed (WrappedMonad m)) d) -> a -> Const (Traversed (WrappedMonad m)) b) -> a -> (c -> m e) -> m () forMOf_ l a f = mapMOf_ l f a {-# INLINE forMOf_ #-} --- | > sequenceOf_ :: Monad m => MultiGetterFamily a b (m b) d -> a -> m ()-sequenceOf_ :: Monad m => ((m c -> Const (Traversal (WrappedMonad m)) d) -> a -> Const (Traversal (WrappedMonad m)) b) -> a -> m ()+-- |+-- > sequence_ = sequenceOf_ folded+--+-- > sequenceOf_ :: Monad m => FoldFamily a b (m b) d -> a -> m ()+sequenceOf_ :: Monad m => ((m c -> Const (Traversed (WrappedMonad m)) d) -> a -> Const (Traversed (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 => MultiGetterFamily a b c d -> a -> f c+-- > asum = asumOf folded+--+-- > asumOf :: Alternative f => FoldFamily a b c d -> a -> f c 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 => MultiGetterFamily a b c d -> a -> m c+-- > msum = msumOf folded+--+-- > msumOf :: MonadPlus m => FoldFamily a b c d -> a -> m c 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 => MultiGetterFamily a b c d -> c -> a -> Bool+-- |+-- > elem = elemOf folded+--+-- > elemOf :: Eq c => FoldFamily a b c d -> c -> a -> Bool elemOf :: Eq c => ((c -> Const Any d) -> a -> Const Any b) -> c -> a -> Bool elemOf l = anyOf l . (==) {-# INLINE elemOf #-} --- | > notElemOf :: Eq c => MultiGetterFamily a b c d -> c -> a -> Bool+-- |+-- > notElem = notElemOf folded+--+-- > notElemOf :: Eq c => FoldFamily a b c d -> c -> a -> Bool notElemOf :: Eq c => ((c -> Const Any d) -> a -> Const Any b) -> c -> a -> Bool notElemOf l c = not . elemOf l c {-# INLINE notElemOf #-} --- | > concatMapOf :: MultiGetterFamily a b c d -> (c -> [e]) -> a -> [e]+-- |+-- > concatMap = concatMapOf folded+--+-- > concatMapOf :: FoldFamily a b c d -> (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 #-} +-- |+-- > concat = concatOf folded+--+-- > concatOf :: FoldFamily a b [e] d -> a -> [e] concatOf :: (([e] -> Const [e] d) -> a -> Const [e] b) -> a -> [e] concatOf = reading {-# INLINE concatOf #-} +------------------------------------------------------------------------------+-- Traversals+------------------------------------------------------------------------------++-- | Every 'Traversal' can be used as a 'TraversalFamily' or a 'Setter' or 'Fold', so it can transitively be used as a+-- 'FoldFamily' or 'SetterFamily' as well.+--+-- > type Traversal a b = TraversalFamily a a b b+type Traversal a b = forall f. Applicative f => (b -> f b) -> a -> f a+++-- | A 'TraversalFamily' can be used directly as a 'SetterFamily' or a 'FoldFamily' and provides+-- the ability to both read and update multiple fields, subject to the (relatively weak) 'TraversalFamily' laws.+--+-- These are also known as @MultiLens@ families, but they have the signature and spirit of+--+-- > traverse :: Traversable f => TraversalFamiy (f a) (f b) a b+--+-- and the more evocative name suggests their application.+type TraversalFamily a b c d = forall f. Applicative f => (c -> f d) -> a -> f b+ ----------------------------- Multilens combinators+-- Traversal combinators -------------------------- +-- |+-- > traverseOf = id+-- > traverse = traverseOf traverse+--+-- > traverseOf :: Applicative f => TraversalFamily a b c d -> (c -> f d) -> a -> f b traverseOf :: Applicative f => ((c -> f d) -> a -> f b) -> (c -> f d) -> a -> f b traverseOf = id {-# INLINE traverseOf #-} +-- |+-- > mapM = mapMOf traverse+--+-- > mapMOf :: Monad m => TraversalFamily a b c d -> (c -> m d) -> a -> m b 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+-- |+-- > sequenceA = sequenceAOf traverse+--+-- > sequenceAOf :: Applicative f => TraversalFamily a b (f c) (f c) -> a -> f b+sequenceAOf :: Applicative f => ((f c -> f (f c)) -> 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+-- |+-- > sequence = sequenceOf traverse+--+-- > sequenceOf :: Monad m => TraversalFamily a b (m c) (m c) -> a -> m b+sequenceOf :: Monad m => ((m c -> WrappedMonad m (m c)) -> a -> WrappedMonad m b) -> a -> m b sequenceOf l = unwrapMonad . l pure {-# INLINE sequenceOf #-} ----------------------------- Multigetters-----------------------------folded :: Foldable f => MultiGetterFamily (f c) b c d-folded = gettingMany id-{-# INLINE folded #-}------------------------------- Multilenses+-- Traversals -------------------------- --- | This is the partial lens that never succeeds at returning any values+-- | This is the traversal that never succeeds at returning any values ----- > constML :: Applicative f => (c -> f d) -> a -> f a-constML :: MultiLensFamily a a c d-constML = const pure-{-# INLINE constML #-}+-- > traverseNothing :: Applicative f => (c -> f d) -> a -> f a+traverseNothing :: TraversalFamily a a c d+traverseNothing = const pure+{-# INLINE traverseNothing #-} --- The multilens for reading and writing to the head of a list+-- The traversal for reading and writing to the head of a list ----- | > headML :: Applicative f => (a -> f a) -> [a] -> f [a]-headML :: MultiLens [a] a-headML _ [] = pure []-headML f (a:as) = (:as) <$> f a-{-# INLINE headML #-}+-- | > traverseHead :: Applicative f => (a -> f a) -> [a] -> f [a]+traverseHead :: Traversal [a] a+traverseHead _ [] = pure []+traverseHead f (a:as) = (:as) <$> f a+{-# INLINE traverseHead #-} --- The multilens for reading and writing to the tail of a list+-- The traversal for reading and writing to the tail of a list ----- | > tailML :: Applicative f => ([a] -> f [a]) -> [a] -> f [a]-tailML :: MultiLens [a] [a]-tailML _ [] = pure []-tailML f (a:as) = (a:) <$> f as-{-# INLINE tailML #-}+-- | > traverseTail :: Applicative f => ([a] -> f [a]) -> [a] -> f [a]+traverseTail :: Traversal [a] [a]+traverseTail _ [] = pure []+traverseTail f (a:as) = (a:) <$> f as+{-# INLINE traverseTail #-} --- | A multilens for tweaking the left-hand value in an Either:+-- | A traversal for tweaking the left-hand value in an Either: ----- > leftML :: Applicative f => (a -> f b) -> Either a c -> f (Either b c)-leftML :: MultiLensFamily (Either a c) (Either b c) a b-leftML f (Left a) = Left <$> f a-leftML _ (Right c) = pure $ Right c-{-# INLINE leftML #-}+-- > traverseLeft :: Applicative f => (a -> f b) -> Either a c -> f (Either b c)+traverseLeft :: TraversalFamily (Either a c) (Either b c) a b+traverseLeft f (Left a) = Left <$> f a+traverseLeft _ (Right c) = pure $ Right c+{-# INLINE traverseLeft #-} --- | A multilens for tweaking the right-hand value in an Either:+-- | traverse the right-hand value in an Either: ----- > rightML :: Applicative f => (a -> f b) -> Either c a -> f (Either c a)--- > rightML = traverse+-- > traverseRight :: Applicative f => (a -> f b) -> Either c a -> f (Either c a)+-- > traverseRight = traverse -- -- Unfortunately the instance for 'Traversable (Either c)' is still missing from--- base.-rightML :: MultiLensFamily (Either c a) (Either c b) a b-rightML _ (Left c) = pure $ Left c-rightML f (Right a) = Right <$> f a-{-# INLINE rightML #-}+-- base, so this can't just be 'traverse'+traverseRight :: TraversalFamily (Either c a) (Either c b) a b+traverseRight _ (Left c) = pure $ Left c+traverseRight f (Right a) = Right <$> f a+{-# INLINE traverseRight #-} --- |--- > keyML :: (Applicative f, Ord k) => k -> (v -> f v) -> Map k v -> f (Map k v)--- > keyML k = keyL k . traverse-keyML :: Ord k => k -> MultiLens (Map k v) v-keyML k = keyL k . traverse-{-# INLINE keyML #-}+-- | Traverse the value at a given key in a Map+--+-- > traverseValueAt :: (Applicative f, Ord k) => k -> (v -> f v) -> Map k v -> f (Map k v)+-- > traverseValueAt k = valueAt k . traverse+traverseValueAt :: Ord k => k -> Traversal (Map k v) v+traverseValueAt k = valueAt k . traverse+{-# INLINE traverseValueAt #-} --- |--- > intKeyML :: Applicative f => Int -> (v -> f v) -> IntMap v -> f (IntMap v)--- > intKeyML k = intKeyL k . traverse-intKeyML :: Int -> MultiLens (IntMap v) v-intKeyML k = intKeyL k . traverse-{-# INLINE intKeyML #-}+-- | Traverse the value at a given key in an IntMap+--+-- > traverseValueAtInt :: Applicative f => Int -> (v -> f v) -> IntMap v -> f (IntMap v)+-- > traverseValueAtInt k = valueAtInt k . traverse+traverseValueAtInt :: Int -> Traversal (IntMap v) v+traverseValueAtInt k = valueAtInt k . traverse+{-# INLINE traverseValueAtInt #-} --- | > elementML :: (Applicative f, Traversable t) => Int -> (a -> f a) -> t a -> f (t a)-elementML :: Traversable t => Int -> MultiLens (t a) a-elementML j f ta = fst (runSA (traverse go ta) 0) where+-- | Traverse a single element in a traversable container.+--+-- > traverseElement :: (Applicative f, Traversable t) => Int -> (a -> f a) -> t a -> f (t a)+traverseElement :: Traversable t => Int -> Traversal (t a) a+traverseElement 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 #-}+{-# INLINE traverseElement #-} +class TraverseByteString t where+ -- | Traverse the individual bytes in a ByteString+ --+ -- > anyOf traverseByteString (==0x80) :: TraverseByteString b => b -> Bool+ traverseByteString :: Traversal t Word8++instance TraverseByteString Strict.ByteString where+ traverseByteString f = fmap Strict.pack . traverse f . Strict.unpack++instance TraverseByteString Lazy.ByteString where+ traverseByteString f = fmap Lazy.pack . traverse f . Lazy.unpack+ ------------------------------------------------------------------------------+-- Cloning Lenses+------------------------------------------------------------------------------++-- | Cloning a 'Lens' or 'LensFamily' is one way to make sure you arent given+-- something weaker, such as a 'Traversal' or 'TraversalFamily', 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+{-# INLINE clone #-}++------------------------------------------------------------------------------ -- Implementation details ------------------------------------------------------------------------------ +data IndexedStore c d a = IndexedStore (d -> a) c++instance Functor (IndexedStore c d) where+ fmap f (IndexedStore g c) = IndexedStore (f . g) c+ newtype SA f a = SA { runSA :: Int -> (f a, Int) } instance Functor f => Functor (SA f) where@@ -763,117 +967,8 @@ (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----------------------------------------------------------------------------------- | By default, if the field name begins with an underscore,--- then the underscore will simply be removed (and the new first character--- lowercased if necessary).-defaultNameTransform :: String -> Maybe String-defaultNameTransform ('_':c:rest) = Just $ toLower c : rest-defaultNameTransform _ = Nothing---- | Information about the larger type the lens will operate on.-type LensTypeInfo = (Name, [TyVarBndr])---- | Information about the smaller type the lens will operate on.-type ConstructorFieldInfo = (Name, Strict, Type)---- | Derive lenses with the provided name transformation--- and filtering function. Produce @Just lensName@ to generate a lens--- of the resultant name, or @Nothing@ to not generate a lens--- for the input record name.------ Example usage:------ > makeLensesBy (\n -> Just (n ++ "L")) ''Foo-makeLensesBy ::- (String -> Maybe String) -- ^ the name transformer- -> Name -> Q [Dec]-makeLensesBy nameTransform datatype = do- typeInfo <- extractLensTypeInfo datatype- let derive1 = deriveLens nameTransform typeInfo- constructorFields <- extractConstructorFields datatype- Prelude.concat <$> Prelude.mapM derive1 constructorFields--extractLensTypeInfo :: Name -> Q LensTypeInfo-extractLensTypeInfo datatype = do- let datatypeStr = nameBase datatype- i <- reify datatype- return $ case i of- TyConI (DataD _ n ts _ _) -> (n, ts)- TyConI (NewtypeD _ n ts _ _) -> (n, ts)- _ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."--extractConstructorFields :: Name -> Q [ConstructorFieldInfo]-extractConstructorFields datatype = do- let datatypeStr = nameBase datatype- i <- reify datatype- return $ case i of- TyConI (DataD _ _ _ [RecC _ fs] _) -> fs- TyConI (NewtypeD _ _ _ (RecC _ fs) _) -> fs- TyConI (DataD _ _ _ [_] _) -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr- TyConI NewtypeD{} -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr- TyConI TySynD{} -> error $ "Can't derive Lens for type synonym: " ++ datatypeStr- TyConI DataD{} -> error $ "Can't derive Lens for tagged union: " ++ datatypeStr- _ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."---- Derive a lens for the given record selector--- using the given name transformation function.-deriveLens :: (String -> Maybe String)- -> LensTypeInfo- -> ConstructorFieldInfo- -> Q [Dec]-deriveLens nameTransform ty field = case nameTransform (nameBase fieldName) of- Nothing -> return []- Just lensNameStr -> do- body <- deriveLensBody (mkName lensNameStr) fieldName- return [body]- where- (fieldName, _fieldStrict, _fieldType) = field- (_tyName, _tyVars) = ty -- just to clarify what's here---- Given a record field name,--- produces a single function declaration:--- lensName f a = (\x -> a { field = x }) `fmap` f (field a)-deriveLensBody :: Name -> Name -> Q Dec-deriveLensBody lensName fieldName = funD lensName [defLine]- where- a = mkName "a"- f = mkName "f"- defLine = clause pats (normalB body) []- pats = [varP f, varP a]- body = [| (\x -> $(record a fieldName [|x|]))- `fmap` $(appE (varE f) (appE (varE fieldName) (varE a)))- |]- record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)]---- | Derive lenses for the record selectors in--- a single-constructor data declaration,--- or for the record selector in a newtype declaration.--- Lenses will only be generated for record fields which--- are prefixed with an underscore.------ Example usage:------ > makeLenses ''Foo-makeLenses :: Name -> Q [Dec]-makeLenses = makeLensesBy defaultNameTransform+newtype Traversed f = Traversed { getTraversed :: f () } --- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.------ Example usage:------ > makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo-makeLensesFor :: [(String, String)] -> Name -> Q [Dec]-makeLensesFor fields = makeLensesBy (`Prelude.lookup` fields)+instance Applicative f => Monoid (Traversed f) where+ mempty = Traversed (pure ())+ Traversed ma `mappend` Traversed mb = Traversed (ma *> mb)
src/Control/Lens/Rep.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Rep@@ -19,6 +19,7 @@ -- -- > import Control.Lens -- > import Control.Lens.Rep+-- > import Control.Lens.TH -- > import Data.Distributive -- -- > data Pair a = Pair { _x :: a, _y :: a }@@ -99,12 +100,12 @@ rep :: (Rep f -> a) -> f a instance Representable Identity where- rep f = Identity (f identityL)+ rep f = Identity (f identity) -- | 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)+ rep f e = f (resultAt e) -- | 'fmapRep' is a valid default definition for 'fmap' for a representable -- functor.
+ src/Control/Lens/TH.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE TemplateHaskell, Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.TH+-- Copyright : (C) 2012 Edward Kmett, Dan Burton+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : TemplateHaskell+--+----------------------------------------------------------------------------+module Control.Lens.TH+ (+ -- ** Constructing Lenses Automatically+ makeLenses+ , makeLensesBy+ , makeLensesFor+ ) where++import Data.Char (toLower)+import Control.Applicative+import Language.Haskell.TH++-------------------------------------+-- Constructing Lenses Automatically+-------------------------------------++-- | Derive lenses for the record selectors in+-- a single-constructor data declaration,+-- or for the record selector in a newtype declaration.+-- Lenses will only be generated for record fields which+-- are prefixed with an underscore.+--+-- Example usage:+--+-- > makeLenses ''Foo+makeLenses :: Name -> Q [Dec]+makeLenses = makeLensesBy defaultNameTransform++-- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.+--+-- Example usage:+--+-- > makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo+makeLensesFor :: [(String, String)] -> Name -> Q [Dec]+makeLensesFor fields = makeLensesBy (`Prelude.lookup` fields)++-- | Derive lenses with the provided name transformation+-- and filtering function. Produce @Just lensName@ to generate a lens+-- of the resultant name, or @Nothing@ to not generate a lens+-- for the input record name.+--+-- Example usage:+--+-- > makeLensesBy (\n -> Just (n ++ "L")) ''Foo+makeLensesBy ::+ (String -> Maybe String) -- ^ the name transformer+ -> Name -> Q [Dec]+makeLensesBy nameTransform datatype = do+ typeInfo <- extractLensTypeInfo datatype+ let derive1 = deriveLens nameTransform typeInfo+ constructorFields <- extractConstructorFields datatype+ Prelude.concat <$> Prelude.mapM derive1 constructorFields++------------------------------------------------------------------------------+-- Template Haskell Implementation Details+------------------------------------------------------------------------------++-- | By default, if the field name begins with an underscore,+-- then the underscore will simply be removed (and the new first character+-- lowercased if necessary).+defaultNameTransform :: String -> Maybe String+defaultNameTransform ('_':c:rest) = Just $ toLower c : rest+defaultNameTransform _ = Nothing++-- | Information about the larger type the lens will operate on.+type LensTypeInfo = (Name, [TyVarBndr])++-- | Information about the smaller type the lens will operate on.+type ConstructorFieldInfo = (Name, Strict, Type)++extractLensTypeInfo :: Name -> Q LensTypeInfo+extractLensTypeInfo datatype = do+ let datatypeStr = nameBase datatype+ i <- reify datatype+ return $ case i of+ TyConI (DataD _ n ts _ _) -> (n, ts)+ TyConI (NewtypeD _ n ts _ _) -> (n, ts)+ _ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."++extractConstructorFields :: Name -> Q [ConstructorFieldInfo]+extractConstructorFields datatype = do+ let datatypeStr = nameBase datatype+ i <- reify datatype+ return $ case i of+ TyConI (DataD _ _ _ [RecC _ fs] _) -> fs+ TyConI (NewtypeD _ _ _ (RecC _ fs) _) -> fs+ TyConI (DataD _ _ _ [_] _) -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr+ TyConI NewtypeD{} -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr+ TyConI TySynD{} -> error $ "Can't derive Lens for type synonym: " ++ datatypeStr+ TyConI DataD{} -> error $ "Can't derive Lens for tagged union: " ++ datatypeStr+ _ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."++-- Derive a lens for the given record selector+-- using the given name transformation function.+deriveLens :: (String -> Maybe String)+ -> LensTypeInfo+ -> ConstructorFieldInfo+ -> Q [Dec]+deriveLens nameTransform ty field = case nameTransform (nameBase fieldName) of+ Nothing -> return []+ Just lensNameStr -> do+ body <- deriveLensBody (mkName lensNameStr) fieldName+ return [body]+ where+ (fieldName, _fieldStrict, _fieldType) = field+ (_tyName, _tyVars) = ty -- just to clarify what's here++-- Given a record field name,+-- produces a single function declaration:+-- lensName f a = (\x -> a { field = x }) `fmap` f (field a)+deriveLensBody :: Name -> Name -> Q Dec+deriveLensBody lensName fieldName = funD lensName [defLine]+ where+ a = mkName "a"+ f = mkName "f"+ defLine = clause pats (normalB body) []+ pats = [varP f, varP a]+ body = [| (\x -> $(record a fieldName [|x|]))+ `fmap` $(appE (varE f) (appE (varE fieldName) (varE a)))+ |]+ record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)]+