Merge pull request #101 from pbrant/add-atraversal

Add ATraversal and cloneTraversal

Author: garyb

src/Data/Lens/Internal/Bazaar.purs

@@ -0,0 +1,31 @@
+module Data.Lens.Internal.Bazaar where
+
+import Prelude
+
+import Data.Bitraversable (bitraverse)
+import Data.Lens.Internal.Wander (class Wander)
+import Data.Profunctor (class Profunctor)
+import Data.Profunctor.Choice (class Choice)
+import Data.Profunctor.Strong (class Strong)
+import Data.Traversable (traverse)
+import Data.Tuple (Tuple(..))
+
+-- | This is used to characterize a Traversal.
+newtype Bazaar p a b s t = Bazaar (forall f. Applicative f => p a (f b) -> s -> f t)
+
+runBazaar :: forall p a b s t. Bazaar p a b s t -> (forall f. Applicative f => p a (f b) -> s -> f t)
+runBazaar (Bazaar x) = x
+
+instance profunctorBazaar :: Profunctor (Bazaar p a b) where
+  dimap f g (Bazaar b) = Bazaar \pafb s -> g <$> b pafb (f s)
+
+instance strongBazaar :: Strong (Bazaar p a b) where
+  first (Bazaar b) = Bazaar (\pafb (Tuple x y) -> flip Tuple y <$> b pafb x)
+  second (Bazaar b) = Bazaar (\pafb (Tuple x y) -> Tuple x <$> b pafb y)
+
+instance choiceBazaar :: Choice (Bazaar p a b) where
+  left  (Bazaar b) = Bazaar (\pafb e -> bitraverse (b pafb) pure e)
+  right (Bazaar b) = Bazaar (\pafb e -> traverse (b pafb) e)
+
+instance wanderBazaar :: Wander (Bazaar p a b) where
+  wander w (Bazaar f) = Bazaar (\pafb s -> w (f pafb) s)

src/Data/Lens/Traversal.purs

@@ -25,6 +25,7 @@ module Data.Lens.Traversal
   , failover
   , elementsOf
   , itraverseOf
+  , cloneTraversal
   , module ExportTypes
   ) where
 
@@ -33,7 +34,8 @@ import Prelude
 import Control.Alternative (class Alternative)
 import Control.Plus (empty)
 import Data.Lens.Indexed (iwander, positions, unIndex)
-import Data.Lens.Types (IndexedTraversal, IndexedOptic, Indexed(..), Traversal, Optic, class Wander, wander)
+import Data.Lens.Internal.Bazaar (Bazaar(..), runBazaar)
+import Data.Lens.Types (ATraversal, IndexedTraversal, IndexedOptic, Indexed(..), Traversal, Optic, class Wander, wander)
 import Data.Lens.Types (Traversal, Traversal') as ExportTypes
 import Data.Monoid.Disj (Disj(..))
 import Data.Newtype (under, unwrap)
@@ -148,3 +150,6 @@ iforOf
   -> (i -> a -> f b)
   -> f t
 iforOf = flip <<< itraverseOf
+
+cloneTraversal :: forall s t a b. ATraversal s t a b -> Traversal s t a b
+cloneTraversal l = wander (runBazaar (l (Bazaar identity)))

src/Data/Lens/Types.purs

@@ -13,6 +13,8 @@ module Data.Lens.Types
   ) where
 
 import Data.Tuple
+
+import Data.Lens.Internal.Bazaar (Bazaar)
 import Data.Lens.Internal.Exchange (Exchange(..))
 import Data.Lens.Internal.Forget (Forget(..))
 import Data.Lens.Internal.Grating (Grating)
@@ -88,8 +90,8 @@ type Iso' s a = Iso s s a a
 type Traversal s t a b = forall p. Wander p => Optic p s t a b
 type Traversal' s a = Traversal s s a a
 
-
-
+type ATraversal s t a b = Optic (Bazaar (->) a b) s t a b
+type ATraversal' s a = ATraversal s s a a
 
 -- | A general-purpose Data.Lens.
 type Optic p s t a b = p a b -> p s t

test/Main.purs

@@ -5,7 +5,7 @@ import Prelude
 import Control.Monad.State (evalState, get)
 import Data.Distributive (class Distributive)
 import Data.Either (Either(..))
-import Data.Lens (Getter', _1, _2, _Just, _Left, collectOf, lens, takeBoth, traversed, view)
+import Data.Lens (Getter', _1, _2, _Just, _Left, collectOf, lens, preview, takeBoth, traversed, view)
 import Data.Lens.Fold ((^?))
 import Data.Lens.Fold.Partial ((^?!), (^@?!))
 import Data.Lens.Grate (Grate, cloneGrate, grate, zipWithOf)
@@ -14,7 +14,8 @@ import Data.Lens.Indexed (itraversed, reindexed)
 import Data.Lens.Lens (ilens, IndexedLens, cloneIndexedLens)
 import Data.Lens.Record (prop)
 import Data.Lens.Setter (iover)
-import Data.Lens.Zoom (IndexedTraversal', Traversal, Traversal', Lens, Lens', zoom)
+import Data.Lens.Traversal (cloneTraversal)
+import Data.Lens.Zoom (ATraversal', IndexedTraversal', Traversal, Traversal', Lens, Lens', zoom)
 import Data.Maybe (Maybe(..))
 import Data.Symbol (SProxy(..))
 import Data.Tuple (Tuple(..), fst, snd)
@@ -94,6 +95,15 @@ collectOfTest = collectOf aGrateExample
 summing :: Tuple Int Int -> Tuple Int Int -> Tuple Int Int
 summing = zipWithOf (cloneGrate aGrateExample) (+)
 
+-- Test cloning of traversals
+cloneTraversalTest :: Maybe Int
+cloneTraversalTest =
+  let t :: Traversal' (Array Int) Int
+      t = ix 1
+      wrapper :: { traversal :: ATraversal' (Array Int) Int }
+      wrapper = { traversal: t }
+  in preview (cloneTraversal wrapper.traversal) [ 0, 1, 2 ]
+
 main :: Effect Unit
 main = do
   logShow $ view bars doc
@@ -104,3 +114,4 @@ main = do
   logShow stateTest
   logShow cloneTest
   logShow (summing (Tuple 1 2) (Tuple 3 4))
+  logShow cloneTraversalTest