Browse files

Added cloneIndexPreservingLens, cloneIndexPreservingTraversal, cloneI…

…ndexPreservingSetter
  • Loading branch information...
1 parent 2e40da2 commit f47d227dfb256d3eee6b8e8810ac983f7cad4afe @ekmett committed Dec 31, 2012
Showing with 36 additions and 7 deletions.
  1. +7 −0 src/Control/Lens/Lens.hs
  2. +9 −3 src/Control/Lens/Setter.hs
  3. +6 −0 src/Control/Lens/Traversal.hs
  4. +14 −4 src/Control/Lens/Type.hs
View
7 src/Control/Lens/Lens.hs
@@ -91,6 +91,7 @@ module Control.Lens.Lens
-- * Cloning Lenses
, cloneLens
+ , cloneIndexPreservingLens
, cloneIndexedLens
-- * ALens Combinators
@@ -106,11 +107,13 @@ module Control.Lens.Lens
) where
import Control.Applicative
+import Control.Comonad
import Control.Lens.Combinators
import Control.Lens.Internal
import Control.Lens.Type
import Control.Monad.State as State
import Data.Monoid
+import Data.Profunctor.Representable
{-# ANN module "HLint: ignore Use ***" #-}
@@ -340,6 +343,10 @@ cloneLens :: ALens s t a b -> Lens s t a b
cloneLens l afb s = runPretext (l sell s) afb
{-# INLINE cloneLens #-}
+cloneIndexPreservingLens :: ALens s t a b -> IndexPreservingLens s t a b
+cloneIndexPreservingLens l pafb = tabulatePro $ \ws -> runPretext (l sell (extract ws)) $ \a -> indexPro pafb (a <$ ws)
+{-# INLINE cloneIndexPreservingLens #-}
+
cloneIndexedLens :: AnIndexedLens i s t a b -> IndexedLens i s t a b
cloneIndexedLens l f s = runPretext (l sell s) (Indexed (indexed f))
{-# INLINE cloneIndexedLens #-}
View
12 src/Control/Lens/Setter.hs
@@ -37,6 +37,7 @@ module Control.Lens.Setter
-- * Building Setters
, sets
, cloneSetter
+ , cloneIndexPreservingSetter
, cloneIndexedSetter
-- * Common Setters
, mapped, lifted
@@ -196,11 +197,16 @@ sets f g = pure `rmap` f (rmap untainted g)
{-# INLINE sets #-}
-- | 'cloneSetter' :: (a -> 'Mutator' b) -> s -> 'Mutator' t) -> IndexPreservingSetter s t a b
-cloneSetter :: ASetter s t a b -> IndexPreservingSetter s t a b
-cloneSetter l pafb = tabulatePro $ \ws ->
- pure . runMutator $ l (\a -> Mutator (untainted (indexPro pafb (a <$ ws)))) (extract ws)
+cloneSetter :: ASetter s t a b -> Setter s t a b
+cloneSetter l afb = taintedDot $ runMutator #. l (Mutator #. untaintedDot afb)
{-# INLINE cloneSetter #-}
+-- | 'cloneSetter' :: (a -> 'Mutator' b) -> s -> 'Mutator' t) -> IndexPreservingSetter s t a b
+cloneIndexPreservingSetter :: ASetter s t a b -> IndexPreservingSetter s t a b
+cloneIndexPreservingSetter l pafb = tabulatePro $ \ws ->
+ pure . runMutator $ l (\a -> Mutator (untainted (indexPro pafb (a <$ ws)))) (extract ws)
+{-# INLINE cloneIndexPreservingSetter #-}
+
cloneIndexedSetter :: AnIndexedSetter i s t a b -> IndexedSetter i s t a b
cloneIndexedSetter l pafb = (pure .# runMutator) . l (Indexed $ \i a -> Mutator #. untainted $ indexed pafb i a)
{-# INLINE cloneIndexedSetter #-}
View
6 src/Control/Lens/Traversal.hs
@@ -57,6 +57,7 @@ module Control.Lens.Traversal
-- * Monomorphic Traversals
, cloneTraversal
+ , cloneIndexPreservingTraversal
, cloneIndexedTraversal
-- * Parts and Holes
@@ -671,6 +672,11 @@ cloneTraversal :: ATraversal s t a b -> Traversal s t a b
cloneTraversal l f s = runBazaar (l sell s) f
{-# INLINE cloneTraversal #-}
+cloneIndexPreservingTraversal :: ATraversal s t a b -> IndexPreservingTraversal s t a b
+cloneIndexPreservingTraversal l pafb = tabulatePro $ \ws -> runBazaar (l sell (extract ws)) $ \a -> indexPro pafb (a <$ ws)
+{-# INLINE cloneIndexPreservingTraversal #-}
+
+
cloneIndexedTraversal :: AnIndexedTraversal i s t a b -> IndexedTraversal i s t a b
cloneIndexedTraversal l f s = runBazaar (l sell s) (Indexed (indexed f))
{-# INLINE cloneIndexedTraversal #-}
View
18 src/Control/Lens/Type.hs
@@ -30,9 +30,9 @@ module Control.Lens.Type
, Action
, MonadicFold
-- * Indexed Variants
- , IndexedLens, IndexedLens'
- , IndexedTraversal, IndexedTraversal'
- , IndexedSetter, IndexedSetter', IndexPreservingSetter
+ , IndexedLens, IndexedLens', IndexPreservingLens, IndexPreservingLens'
+ , IndexedTraversal, IndexedTraversal', IndexPreservingTraversal, IndexPreservingTraversal'
+ , IndexedSetter, IndexedSetter', IndexPreservingSetter, IndexPreservingSetter'
, IndexedGetter, IndexPreservingGetter
, IndexedFold, IndexPreservingFold
, IndexedAction, IndexPreservingAction
@@ -115,6 +115,10 @@ type IndexedLens i s t a b = forall f p. (Indexable i p, Functor f) => p a (f b)
-- | @type 'IndexedLens'' i = 'Simple' ('IndexedLens' i)@
type IndexedLens' i s a = IndexedLens i s s a a
+type IndexPreservingLens s t a b = forall p f. (SelfAdjoint p, Functor f) => p a (f b) -> p s (f t)
+
+type IndexPreservingLens' s a = IndexPreservingLens s s a a
+
------------------------------------------------------------------------------
-- Traversals
------------------------------------------------------------------------------
@@ -160,11 +164,15 @@ type Traversal' s a = Traversal s s a a
-- directly as a 'Control.Lens.Traversal.Traversal'.
--
-- The 'Control.Lens.Traversal.Traversal' laws are still required to hold.
-type IndexedTraversal i s t a b = forall f p. (Indexable i p, Applicative f) => p a (f b) -> s -> f t
+type IndexedTraversal i s t a b = forall p f. (Indexable i p, Applicative f) => p a (f b) -> s -> f t
-- | @type 'IndexedTraversal'' i = 'Simple' ('IndexedTraversal' i)@
type IndexedTraversal' i s a = IndexedTraversal i s s a a
+type IndexPreservingTraversal s t a b = forall p f. (SelfAdjoint p, Applicative f) => p a (f b) -> p s (f t)
+
+type IndexPreservingTraversal' s a = IndexPreservingTraversal s s a a
+
------------------------------------------------------------------------------
-- Setters
------------------------------------------------------------------------------
@@ -234,6 +242,8 @@ type IndexedSetter' i s a = IndexedSetter i s s a a
-- and leaves the index intact, yielding an 'IndexedSetter'.
type IndexPreservingSetter s t a b = forall p f. (SelfAdjoint p, Settable f) => p a (f b) -> p s (f t)
+type IndexPreservingSetter' s a = IndexPreservingSetter s s a a
+
-----------------------------------------------------------------------------
-- Isomorphisms
-----------------------------------------------------------------------------

0 comments on commit f47d227

Please sign in to comment.