Add affine traversals (#112)

* Add type synonym for affine traversal

* Formulate Index in terms of AffineTraversal'

Sorry for the ugly duplication with At, maybe we want to put them in the same module? Then index i = at i <<< _Just

* Add `AffineTraversal` and `Stall`

* Fix build

* Re-export Stall

* Fix the Index instance of Set

* Really fix the Index instance of Set

* Fix AffineTraversal intro text.

Co-authored-by: Nicholas Scheel <[email protected]>

src/Data/Lens/AffineTraversal.purs

@@ -0,0 +1,52 @@
+-- | This module defines functions for working with affine traversals.
+-- | An `AffineTraversal` is a `Traversal` that applies to at most one element.
+-- |
+-- | These arise most frequently as the composition of a `Lens` with a `Prism`.
+module Data.Lens.AffineTraversal
+  ( affineTraversal
+  , affineTraversal'
+  , withAffineTraversal
+  , cloneAffineTraversal
+  , module Data.Lens.Types
+  ) where
+
+import Prelude
+
+import Data.Either (Either(..), either)
+import Data.Lens.Internal.Stall (Stall(..))
+import Data.Lens.Types (AffineTraversal, AffineTraversal', AnAffineTraversal, AnAffineTraversal')
+import Data.Profunctor (dimap)
+import Data.Profunctor.Choice (right)
+import Data.Profunctor.Strong (second, (&&&))
+import Data.Tuple (Tuple(..))
+
+affineTraversal ::
+  forall s t a b .
+  (s -> b -> t) ->
+  (s -> Either t a) ->
+  AffineTraversal s t a b
+affineTraversal set pre =
+  affineTraversal' (set &&& pre)
+
+affineTraversal' ::
+  forall s t a b .
+  (s -> Tuple (b -> t) (Either t a)) ->
+  AffineTraversal s t a b
+affineTraversal' to pab =
+  dimap to (\(Tuple b f) -> either identity b f) (second (right pab))
+
+withAffineTraversal ::
+  forall s t a b r .
+  AnAffineTraversal s t a b ->
+  ((s -> b -> t) -> (s -> Either t a) -> r) ->
+  r
+withAffineTraversal l f = case l (Stall (const identity) Right) of
+  Stall g h -> f g h
+
+cloneAffineTraversal ::
+  forall s t a b .
+  AnAffineTraversal s t a b ->
+  AffineTraversal s t a b
+cloneAffineTraversal l =
+  withAffineTraversal l \x y p ->
+    affineTraversal x y p

src/Data/Lens/At.purs

@@ -10,27 +10,27 @@ import Data.Identity (Identity(..))
 import Data.Lens (Lens', lens)
 import Data.Lens.Index (class Index)
 import Data.Map as M
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), maybe, maybe')
 import Data.Newtype (unwrap)
 import Data.Set as S
 import Foreign.Object as FO
 
 -- | `At` is a type class whose instances let you add
 -- | new elements or delete old ones from "container-like" types:
--- | 
--- | ```purescript 
+-- |
+-- | ```purescript
 -- | whole = Map.singleton "key" "value"
 -- | optic = at "key"
 -- |
 -- | view optic whole == Just "value"
--- | 
+-- |
 -- | set optic (Just "NEW") whole == Map.singleton "key" "NEW"
--- | 
+-- |
 -- | set optic Nothing whole == Map.empty
 -- | ```
 -- |
 -- | If you don't want to add or delete, but only to view or change
--- | an existing element, see `Data.Lens.Index`. 
+-- | an existing element, see `Data.Lens.Index`.
 
 class Index m a b <= At m a b | m -> a, m -> b where
   at :: a -> Lens' m (Maybe b)
@@ -54,9 +54,9 @@ instance atSet :: Ord v => At (S.Set v) v Unit where
 instance atMap :: Ord k => At (M.Map k v) k v where
   at k =
     lens (M.lookup k) \m ->
-      maybe (M.delete k m) \v -> M.insert k v m
+      maybe' (\_ -> M.delete k m) \v -> M.insert k v m
 
 instance atForeignObject :: At (FO.Object v) String v where
   at k =
     lens (FO.lookup k) \m ->
-      maybe (FO.delete k m) \ v -> FO.insert k v m
+      maybe' (\_ -> FO.delete k m) \v -> FO.insert k v m

src/Data/Lens/Index.purs

@@ -7,16 +7,18 @@ import Prelude
 
 import Data.Array as A
 import Data.Array.NonEmpty as NEA
+import Data.Either (Either(..))
 import Data.Identity (Identity)
-import Data.Lens.Internal.Wander (wander)
-import Data.Lens.Types (Traversal')
-import Data.List (List(..), (:))
+import Data.Lens (_Just, lens)
+import Data.Lens.Iso.Newtype (_Newtype)
+import Data.Lens.AffineTraversal (AffineTraversal', affineTraversal)
+import Data.List as L
 import Data.Map as M
-import Data.Maybe (Maybe, maybe, fromMaybe)
+import Data.Maybe (Maybe(..), maybe, fromMaybe)
 import Data.Set as S
-import Data.Traversable (traverse)
 import Foreign.Object as FO
 
+
 -- | `Index` is a type class whose instances are optics used when:
 -- | 1. The focus element might not be present.
 -- | 2. You either cannot or do not want to add new elements or delete existing ones.
@@ -47,61 +49,61 @@ import Foreign.Object as FO
 -- | If you *do* want to add or delete elements, see `Data.Lens.At`.
 
 class Index m a b | m -> a, m -> b where
-  ix :: a -> Traversal' m b
+  ix :: a -> AffineTraversal' m b
 
-instance indexArr :: Eq i => Index (i -> a) i a where
-  ix i =
-    wander \coalg f ->
-      coalg (f i) <#> \a j ->
-        if i == j then a else f j
+instance indexFn :: Eq i => Index (i -> a) i a where
+  ix i = lens (\f -> f i) \f a j -> if i == j then a else f j
 
 instance indexMaybe :: Index (Maybe a) Unit a where
-  ix _ = wander traverse
+  ix _ = _Just
 
 instance indexIdentity :: Index (Identity a) Unit a where
-  ix _ = wander traverse
+  ix _ = _Newtype
 
 instance indexArray :: Index (Array a) Int a where
-  ix n =
-    wander \coalg xs ->
-      xs A.!! n #
-        maybe
-          (pure xs)
-          (coalg >>> map \x -> fromMaybe xs (A.updateAt n x xs))
+  ix n = affineTraversal set pre
+    where
+      set :: Array a -> a -> Array a
+      set s b = fromMaybe s $ A.updateAt n b s
+      pre :: Array a -> Either (Array a) a
+      pre s = maybe (Left s) Right $ A.index s n
 
 instance indexNonEmptyArray :: Index (NEA.NonEmptyArray a) Int a where
-  ix n =
-    wander \coalg xs ->
-      xs NEA.!! n #
-        maybe
-          (pure xs)
-          (coalg >>> map \x -> fromMaybe xs (NEA.updateAt n x xs))
+  ix n = affineTraversal set pre
+    where
+      set :: NEA.NonEmptyArray a -> a -> NEA.NonEmptyArray a
+      set s b = fromMaybe s $ NEA.updateAt n b s
+      pre :: NEA.NonEmptyArray a -> Either (NEA.NonEmptyArray a) a
+      pre s = maybe (Left s) Right $ NEA.index s n
 
-instance indexList :: Index (List a) Int a where
-  ix n | n < 0     = wander \_ xs -> pure xs
-       | otherwise = wander \coalg xs -> go xs n coalg where
-    go :: forall f. Applicative f => List a -> Int -> (a -> f a) -> f (List a)
-    go Nil _ _ = pure Nil
-    go (a:as) 0 coalg = coalg a <#> (_:as)
-    go (a:as) i coalg = (a:_) <$> (go as (i - 1) coalg)
+instance indexList :: Index (L.List a) Int a where
+  ix n = affineTraversal set pre
+    where
+      set :: L.List a -> a -> L.List a
+      set s b = fromMaybe s $ L.updateAt n b s
+      pre :: L.List a -> Either (L.List a) a
+      pre s = maybe (Left s) Right $ L.index s n
 
 instance indexSet :: Ord a => Index (S.Set a) a Unit where
-  ix x =
-    wander \coalg ->
-      pure <<< S.insert x
+  ix x = affineTraversal set pre
+    where
+      set :: S.Set a -> Unit -> S.Set a
+      set xs _ = xs
+      pre :: S.Set a -> Either (S.Set a) Unit
+      pre xs = if S.member x xs then Right unit else Left xs
 
 instance indexMap :: Ord k => Index (M.Map k v) k v where
-  ix k =
-    wander \coalg m ->
-      M.lookup k m #
-        maybe
-          (pure m)
-          (coalg >>> map \v -> M.insert k v m)
+  ix k = affineTraversal set pre
+    where
+      set :: M.Map k v -> v -> M.Map k v
+      set s b = M.update (\_ -> Just b) k s
+      pre :: M.Map k v -> Either (M.Map k v) v
+      pre s = maybe (Left s) Right $ M.lookup k s
 
 instance indexForeignObject :: Index (FO.Object v) String v where
-  ix k =
-    wander \coalg m ->
-      FO.lookup k m #
-        maybe
-          (pure m)
-          (coalg >>> map \v -> FO.insert k v m)
+  ix k = affineTraversal set pre
+    where
+      set :: FO.Object v -> v -> FO.Object v
+      set s b = FO.update (\_ -> Just b) k s
+      pre :: FO.Object v -> Either (FO.Object v) v
+      pre s = maybe (Left s) Right $ FO.lookup k s

src/Data/Lens/Internal/Stall.purs

@@ -0,0 +1,50 @@
+-- | This module defines the `Stall` profunctor
+module Data.Lens.Internal.Stall where
+
+import Prelude
+
+import Data.Bifunctor (lmap)
+import Data.Either (Either(..))
+import Data.Profunctor (class Profunctor)
+import Data.Profunctor.Strong (class Strong)
+import Data.Profunctor.Choice (class Choice)
+import Data.Tuple (Tuple(..))
+
+-- | The `Stall` profunctor characterizes an `AffineTraversal`.
+data Stall a b s t = Stall (s -> b -> t) (s -> Either t a)
+
+instance functorStall :: Functor (Stall a b s) where
+  map f (Stall u p) =
+    Stall (map f <<< u) (lmap f <<< p)
+
+instance profunctorStall :: Profunctor (Stall a b) where
+  dimap f g (Stall u p) =
+    Stall (map g <<< u <<< f) (lmap g <<< p <<< f)
+
+instance strongStall :: Strong (Stall a b) where
+  first (Stall u p) =
+    Stall (\(Tuple s x) b -> Tuple (u s b) x)
+          (\(Tuple s x) -> lmap (\t -> Tuple t x) (p s))
+
+  second (Stall u p) =
+    Stall (\(Tuple x s) b -> Tuple x (u s b))
+          (\(Tuple x s) -> lmap (Tuple x) (p s))
+
+instance choiceStall :: Choice (Stall a b) where
+  left (Stall u p) =
+    Stall
+      (case _ of
+        Left s -> \b -> Left (u s b)
+        Right x -> \_ -> Right x)
+      (case _ of
+        Left s -> lmap Left (p s)
+        Right x -> Left (Right x))
+
+  right (Stall u p) =
+    Stall
+      (case _ of
+        Left x -> \_ -> Left x
+        Right s -> \b -> Right (u s b))
+      (case _ of
+        Left x -> Left (Left x)
+        Right s -> lmap Right (p s))

src/Data/Lens/Types.purs

@@ -4,6 +4,7 @@ module Data.Lens.Types
   , module Data.Lens.Internal.Exchange
   , module Data.Lens.Internal.Market
   , module Data.Lens.Internal.Shop
+  , module Data.Lens.Internal.Stall
   , module Data.Lens.Internal.Tagged
   , module Data.Lens.Internal.Forget
   , module Data.Lens.Internal.Grating
@@ -22,6 +23,7 @@ import Data.Lens.Internal.Indexed (Indexed(..))
 import Data.Lens.Internal.Market (Market(..))
 import Data.Lens.Internal.Re (Re(..))
 import Data.Lens.Internal.Shop (Shop(..))
+import Data.Lens.Internal.Stall (Stall(..))
 import Data.Lens.Internal.Tagged (Tagged(..))
 import Data.Lens.Internal.Wander (class Wander, wander)
 import Data.Profunctor (class Profunctor)
@@ -31,8 +33,8 @@ import Data.Profunctor.Strong (class Strong)
 
 -- | Given a type whose "focus element" always exists,
 -- | a lens provides a convenient way to view, set, and transform
--- | that element. 
--- | 
+-- | that element.
+-- |
 -- | For example, `_2` is a tuple-specific `Lens` available from `Data.Lens`, so:
 -- | ```purescript
 -- | over _2 String.length $ Tuple "ignore" "four" == Tuple "ignore" 4
@@ -44,7 +46,7 @@ import Data.Profunctor.Strong (class Strong)
 -- | * `t` is `Tuple String Int`
 -- | * `a` is `String`
 -- | * `b` is `Int`
--- | 
+-- |
 -- | See `Data.Lens.Getter` and `Data.Lens.Setter` for functions and operators
 -- | frequently used with lenses.
 
@@ -56,7 +58,7 @@ type Lens s t a b = forall p. Strong p => Optic p s t a b
 -- | not its type. As an example, consider the `Lens` `_2`, which has this type:
 -- |
 -- | ```purescript
--- | _2 :: forall s t a b. Lens (Tuple s a) (Tuple t b) a b 
+-- | _2 :: forall s t a b. Lens (Tuple s a) (Tuple t b) a b
 -- | ```
 -- |
 -- | `_2` can produce a `Tuple Int String` from a `Tuple Int Int`:
@@ -113,6 +115,13 @@ type AnIndexedLens' i s a = AnIndexedLens i s s a a
 type APrism s t a b = Optic (Market a b) s t a b
 type APrism' s a = APrism s s a a
 
+-- | An affine traversal (has at most one focus, but is not a prism).
+type AffineTraversal s t a b = forall p. Strong p => Choice p => Optic p s t a b
+type AffineTraversal' s a = AffineTraversal s s a a
+
+type AnAffineTraversal s t a b = Optic (Stall a b) s t a b
+type AnAffineTraversal' s a = AnAffineTraversal s s a a
+
 -- | A grate (http://r6research.livejournal.com/28050.html)
 type Grate s t a b = forall p. Closed p => Optic p s t a b
 type Grate' s a = Grate s s a a