From d8c2e33f9bd046b4c4a454c1a66720a330b89ddd Mon Sep 17 00:00:00 2001
From: Bhavik Mehta <bhavikmehta8@gmail.com>
Date: Wed, 7 Aug 2019 15:01:59 +0100
Subject: [PATCH 1/3] A plethora of optics

---
 src/Control/Optics/Linear/Internal.hs | 82 ++++++++++++++++++++++++---
 src/Data/Profunctor/Kleisli/Linear.hs | 12 +---
 src/Data/Profunctor/Linear.hs         | 50 +++++++++++++++-
 src/Foreign/Marshal/Pure.hs           |  2 +-
 src/Prelude/Linear.hs                 |  2 +-
 src/System/IO/Linear.hs               |  1 +
 6 files changed, 125 insertions(+), 24 deletions(-)

diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs
index 520f35f2..ede1b9e3 100644
--- a/src/Control/Optics/Linear/Internal.hs
+++ b/src/Control/Optics/Linear/Internal.hs
@@ -13,7 +13,8 @@ module Control.Optics.Linear.Internal
   , Iso, Iso'
   , Lens, Lens'
   , Prism, Prism'
-  , Traversal, Traversal'
+  , PTraversal, PTraversal'
+  , DTraversal, DTraversal'
     -- * Composing optics
   , (.>)
     -- * Common optics
@@ -21,29 +22,39 @@ module Control.Optics.Linear.Internal
   , _1, _2
   , _Left, _Right
   , _Just, _Nothing
-  , traversed
+  , ptraversed, dtraversed
+  , both, both'
     -- * Using optics
   , get, set, gets
+  , set', set''
   , match, build
+  , preview
   , over, over'
   , traverseOf, traverseOf'
   , lengthOf
-  , withIso, withPrism
+  , withIso, withLens, withPrism
+  , toListOf
     -- * Constructing optics
-  , iso, prism
+  , iso, prism, lens
   )
   where
 
 import qualified Control.Arrow as NonLinear
 import qualified Data.Bifunctor.Linear as Bifunctor
+import qualified Control.Monad.Linear as Control
 import Data.Bifunctor.Linear (SymmetricMonoidal)
-import Data.Profunctor.Linear
+import Data.Monoid.Linear
+import Data.Functor.Const
 import Data.Functor.Linear
+import Data.Profunctor.Linear
 import qualified Data.Profunctor.Kleisli.Linear as Linear
 import Data.Void
 import Prelude.Linear
 import qualified Prelude as P
 
+-- TODO: documentation in this module
+-- Put the functions in some sensible order: possibly split into separate
+-- Lens/Prism/Traversal/Iso modules
 newtype Optic_ arr a b s t = Optical (a `arr` b -> s `arr` t)
 
 type Optic c a b s t =
@@ -55,8 +66,12 @@ type Lens a b s t = Optic (Strong (,) ()) a b s t
 type Lens' a s = Lens a a s s
 type Prism a b s t = Optic (Strong Either Void) a b s t
 type Prism' a s = Prism a a s s
-type Traversal a b s t = Optic Wandering a b s t
-type Traversal' a s = Traversal a a s s
+type PTraversal a b s t = Optic PWandering a b s t
+type PTraversal' a s = PTraversal a a s s
+type DTraversal a b s t = Optic DWandering a b s t
+type DTraversal' a s = DTraversal a a s s
+-- XXX: these will unify into
+-- type Traversal (p :: Multiplicity) a b s t = Optic (Wandering p) a b s t
 
 swap :: SymmetricMonoidal m u => Iso (a `m` b) (c `m` d) (b `m` a) (d `m` c)
 swap = iso Bifunctor.swap Bifunctor.swap
@@ -67,6 +82,12 @@ assoc = iso Bifunctor.lassoc Bifunctor.rassoc
 (.>) :: Optic_ arr a b s t -> Optic_ arr x y a b -> Optic_ arr x y s t
 Optical f .> Optical g = Optical (f P.. g)
 
+lens :: (s ->. (a, b ->. t)) -> Lens a b s t
+lens k = Optical $ \f -> dimap k (\(x,g) -> g $ x) (first f)
+
+withLens :: Optic_ (Linear.Kleisli (OtherFunctor a b)) a b s t -> s ->. (a, b ->. t)
+withLens (Optical l) s = runOtherFunctor (Linear.runKleisli (l (Linear.Kleisli (\a -> OtherFunctor (a, id)))) s)
+
 prism :: (b ->. t) -> (s ->. Either t a) -> Prism a b s t
 prism b s = Optical $ \f -> dimap s (either id id) (second (rmap b f))
 
@@ -76,6 +97,37 @@ _1 = Optical first
 _2 :: Lens a b (c,a) (c,b)
 _2 = Optical second
 
+-- XXX: these will unify to
+-- > both :: forall (p :: Multiplicity). Traversal p a b (a,a) (b,b)
+both' :: PTraversal a b (a,a) (b,b)
+both' = _Pairing .> ptraversed
+
+both :: DTraversal a b (a,a) (b,b)
+both = _Pairing .> dtraversed
+
+-- XXX: these are a special case of Bitraversable, but just the simple case
+-- is included here for now
+_Pairing :: Iso (Pair a) (Pair b) (a,a) (b,b)
+_Pairing = iso Paired unpair
+
+newtype Pair a = Paired (a,a)
+unpair :: Pair a ->. (a,a)
+unpair (Paired x) = x
+
+instance P.Functor Pair where
+  fmap f (Paired (x,y)) = Paired (f x, f y)
+instance Functor Pair where
+  fmap f (Paired (x,y)) = Paired (f x, f y)
+instance Foldable Pair where
+  foldMap f (Paired (x,y)) = f x P.<> f y
+instance P.Traversable Pair where
+  traverse f (Paired (x,y)) = Paired P.<$> ((,) P.<$> f x P.<*> f y)
+instance Traversable Pair where
+  traverse f (Paired (x,y)) = Paired <$> ((,) <$> f x <*> f y)
+
+toListOf :: Optic_ (NonLinear.Kleisli (Const [a])) a b s t -> s -> [a]
+toListOf l = gets l (\a -> [a])
+
 _Left :: Prism a b (Either a c) (Either b c)
 _Left = Optical first
 
@@ -88,8 +140,11 @@ _Just = prism Just (maybe (Left Nothing) Right)
 _Nothing :: Prism' () (Maybe a)
 _Nothing = prism (\() -> Nothing) Left
 
-traversed :: Traversable t => Traversal a b (t a) (t b)
-traversed = Optical wander
+ptraversed :: P.Traversable t => PTraversal a b (t a) (t b)
+ptraversed = Optical pwander
+
+dtraversed :: Traversable t => DTraversal a b (t a) (t b)
+dtraversed = Optical dwander
 
 over :: Optic_ LinearArrow a b s t -> (a ->. b) -> s ->. t
 over (Optical l) f = getLA (l (LA f))
@@ -103,6 +158,15 @@ get l = gets l P.id
 gets :: Optic_ (NonLinear.Kleisli (Const r)) a b s t -> (a -> r) -> s -> r
 gets (Optical l) f s = getConst' (NonLinear.runKleisli (l (NonLinear.Kleisli (Const P.. f))) s)
 
+preview :: Optic_ (NonLinear.Kleisli (Const (Maybe (First a)))) a b s t -> s -> Maybe a
+preview l s = P.fmap getFirst (gets l (\a -> Just (First a)) s)
+
+set' :: Optic_ (Linear.Kleisli (MyFunctor a b)) a b s t -> s ->. b ->. (a, t)
+set' (Optical l) s = runMyFunctor (Linear.runKleisli (l (Linear.Kleisli (\a -> MyFunctor (\b -> (a,b))))) s)
+
+set'' :: Optic_ (NonLinear.Kleisli (Control.Reader b)) a b s t -> b ->. s -> t
+set'' (Optical l) b s = Control.runReader (NonLinear.runKleisli (l (NonLinear.Kleisli (const (Control.reader id)))) s) b
+
 set :: Optic_ (->) a b s t -> b -> s -> t
 set (Optical l) x = l (const x)
 
diff --git a/src/Data/Profunctor/Kleisli/Linear.hs b/src/Data/Profunctor/Kleisli/Linear.hs
index 61951ef5..6394c788 100644
--- a/src/Data/Profunctor/Kleisli/Linear.hs
+++ b/src/Data/Profunctor/Kleisli/Linear.hs
@@ -41,22 +41,14 @@ instance Control.Applicative f => Strong Either Void (Kleisli f) where
   first  (Kleisli f) = Kleisli (either (Data.fmap Left . f) (Control.pure . Right))
   second (Kleisli g) = Kleisli (either (Control.pure . Left) (Data.fmap Right . g))
 
-instance Control.Applicative f => Wandering (Kleisli f) where
-  wander (Kleisli f) = Kleisli (Data.traverse f)
+instance Control.Applicative f => DWandering (Kleisli f) where
+  dwander (Kleisli f) = Kleisli (Data.traverse f)
 
 -- | Linear co-Kleisli arrows for the comonad `w`. These arrows are still
 -- useful in the case where `w` is not a comonad however, and some
 -- profunctorial properties still hold in this weaker setting.
 -- However stronger requirements on `f` are needed for profunctorial
 -- strength, so we have fewer instances.
---
--- Category theoretic remark: duality doesn't work in the obvious way, since
--- (,) isn't the categorical product. Instead, we have a product (&), called
--- "With", defined by
--- > type With a b = forall r. Either (a ->. r) (b ->. r) ->. r
--- which satisfies the universal property of the product of `a` and `b`.
--- CoKleisli arrows are strong with respect to this monoidal structure,
--- although this might not be useful...
 newtype CoKleisli w a b = CoKleisli { runCoKleisli :: w a ->. b }
 
 instance Data.Functor f => Profunctor (CoKleisli f) where
diff --git a/src/Data/Profunctor/Linear.hs b/src/Data/Profunctor/Linear.hs
index 9e6037c0..6fc6a7f8 100644
--- a/src/Data/Profunctor/Linear.hs
+++ b/src/Data/Profunctor/Linear.hs
@@ -1,23 +1,32 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Data.Profunctor.Linear
   ( Profunctor(..)
   , Monoidal(..)
   , Strong(..)
-  , Wandering(..)
+  , PWandering(..)
+  , DWandering(..)
   , LinearArrow(..), getLA
   , Exchange(..)
   , Market(..), runMarket
+  , MyFunctor(..), runMyFunctor
+  , OtherFunctor(..), runOtherFunctor
   ) where
 
 import qualified Data.Functor.Linear as Data
+import qualified Control.Monad.Linear as Control
 import Data.Bifunctor.Linear hiding (first, second)
 import Prelude.Linear
 import Data.Void
@@ -56,8 +65,17 @@ class (SymmetricMonoidal m u, Profunctor arr) => Strong m u arr where
   second arr = dimap swap swap (first arr)
   {-# INLINE second #-}
 
-class (Strong (,) () arr, Strong Either Void arr) => Wandering arr where
-  wander :: Data.Traversable f => a `arr` b -> f a `arr` f b
+-- XXX: Just as Prelude.Functor/Data.Functor will combine into
+-- > `class Functor (p :: Multiplicity) f`
+-- so will Traversable, and then we would instead write
+-- > class (...) => Wandering (p :: Multiplicity) arr where
+-- >   wander :: Traversable p f => a `arr` b -> f a `arr` f b
+-- For now, however, we cannot do this, so we use two classes instead:
+-- PreludeWandering and DataWandering
+class (Strong (,) () arr, Strong Either Void arr) => PWandering arr where
+  pwander :: Prelude.Traversable f => a `arr` b -> f a `arr` f b
+class (Strong (,) () arr, Strong Either Void arr) => DWandering arr where
+  dwander :: Data.Traversable f => a `arr` b -> f a `arr` f b
 
 ---------------
 -- Instances --
@@ -79,6 +97,9 @@ instance Strong Either Void LinearArrow where
   first  (LA f) = LA $ either (Left . f) Right
   second (LA g) = LA $ either Left (Right . g)
 
+instance DWandering LinearArrow where
+  dwander (LA f) = LA (Data.fmap f)
+
 instance Profunctor (->) where
   dimap f g h x = g (h (f x))
 instance Strong (,) () (->) where
@@ -86,6 +107,8 @@ instance Strong (,) () (->) where
 instance Strong Either Void (->) where
   first f (Left x) = Left (f x)
   first _ (Right y) = Right y
+instance PWandering (->) where
+  pwander = Prelude.fmap
 
 data Exchange a b s t = Exchange (s ->. a) (b ->. t)
 instance Profunctor (Exchange a b) where
@@ -112,3 +135,24 @@ instance Profunctor (Market a b) where
 
 instance Strong Either Void (Market a b) where
   first (Market f g) = Market (Left . f) (either (either (Left . Left) Right . g) (Left . Right))
+
+instance Prelude.Applicative f => PWandering (Kleisli f) where
+  pwander (Kleisli f) = Kleisli (Prelude.traverse f)
+
+-- TODO: pick a more sensible name for this
+newtype MyFunctor a b t = MyFunctor (b ->. (a, t))
+runMyFunctor :: MyFunctor a b t ->. b ->. (a, t)
+runMyFunctor (MyFunctor f) = f
+
+instance Data.Functor (MyFunctor a b) where
+  fmap f (MyFunctor g) = MyFunctor (getLA (second (LA f)) . g)
+instance Control.Functor (MyFunctor a b) where
+  fmap f (MyFunctor g) = MyFunctor (Control.fmap f . g)
+
+newtype OtherFunctor a b t = OtherFunctor (a, b ->. t)
+runOtherFunctor :: OtherFunctor a b t ->. (a, b ->. t)
+runOtherFunctor (OtherFunctor f) = f
+instance Data.Functor (OtherFunctor a b) where
+  fmap f (OtherFunctor (a,g)) = OtherFunctor (a,f . g)
+instance Control.Functor (OtherFunctor a b) where
+  fmap f (OtherFunctor (a,g)) = OtherFunctor (a,f . g)
diff --git a/src/Foreign/Marshal/Pure.hs b/src/Foreign/Marshal/Pure.hs
index 648085c0..0dbd6416 100644
--- a/src/Foreign/Marshal/Pure.hs
+++ b/src/Foreign/Marshal/Pure.hs
@@ -60,7 +60,7 @@ import Foreign.Marshal.Utils
 import Foreign.Ptr
 import Foreign.Storable
 import Foreign.Storable.Tuple ()
-import Prelude (($), return, (<*>))
+import Prelude (($), return, (<*>), (<$>))
 import Prelude.Linear hiding (($))
 import System.IO.Unsafe
 import qualified Unsafe.Linear as Unsafe
diff --git a/src/Prelude/Linear.hs b/src/Prelude/Linear.hs
index 9d2f571b..59506ed8 100644
--- a/src/Prelude/Linear.hs
+++ b/src/Prelude/Linear.hs
@@ -53,7 +53,7 @@ import Prelude hiding
   , foldr
   , maybe
   , (.)
-  , Functor(..)
+  , Functor(..), (<$>)
   , Applicative(..)
   , Monad(..)
   , Traversable(..)
diff --git a/src/System/IO/Linear.hs b/src/System/IO/Linear.hs
index bf6ee2fc..453b6540 100644
--- a/src/System/IO/Linear.hs
+++ b/src/System/IO/Linear.hs
@@ -41,6 +41,7 @@ import qualified Control.Monad.Linear as Control
 import qualified Data.Functor.Linear as Data
 import GHC.Exts (State#, RealWorld)
 import Prelude.Linear hiding (IO)
+import Prelude ((<$>))
 import qualified Unsafe.Linear as Unsafe
 import qualified System.IO as System
 

From a7e68fcd45841c157c2ca40e4ef7e2780270ba0c Mon Sep 17 00:00:00 2001
From: Bhavik Mehta <bhavikmehta8@gmail.com>
Date: Thu, 12 Sep 2019 11:03:35 +0200
Subject: [PATCH 2/3] Batch traversals

---
 src/Control/Optics/Linear/Internal.hs         | 61 ++++++++++---------
 .../Functor/Linear/Internal/Traversable.hs    | 27 ++++++++
 src/Data/Profunctor/Kleisli/Linear.hs         |  7 ++-
 src/Data/Profunctor/Linear.hs                 | 42 ++++++-------
 4 files changed, 81 insertions(+), 56 deletions(-)

diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs
index ede1b9e3..17b5334e 100644
--- a/src/Control/Optics/Linear/Internal.hs
+++ b/src/Control/Optics/Linear/Internal.hs
@@ -13,8 +13,7 @@ module Control.Optics.Linear.Internal
   , Iso, Iso'
   , Lens, Lens'
   , Prism, Prism'
-  , PTraversal, PTraversal'
-  , DTraversal, DTraversal'
+  , Traversal, Traversal'
     -- * Composing optics
   , (.>)
     -- * Common optics
@@ -22,8 +21,8 @@ module Control.Optics.Linear.Internal
   , _1, _2
   , _Left, _Right
   , _Just, _Nothing
-  , ptraversed, dtraversed
-  , both, both'
+  , traversed
+  , both
     -- * Using optics
   , get, set, gets
   , set', set''
@@ -32,16 +31,17 @@ module Control.Optics.Linear.Internal
   , over, over'
   , traverseOf, traverseOf'
   , lengthOf
-  , withIso, withLens, withPrism
   , toListOf
+  , withIso, withLens, withPrism, withTraversal
     -- * Constructing optics
-  , iso, prism, lens
+  , iso, prism, lens, traversal
   )
   where
 
 import qualified Control.Arrow as NonLinear
 import qualified Data.Bifunctor.Linear as Bifunctor
 import qualified Control.Monad.Linear as Control
+import Data.Functor.Linear.Internal.Traversable
 import Data.Bifunctor.Linear (SymmetricMonoidal)
 import Data.Monoid.Linear
 import Data.Functor.Const
@@ -66,12 +66,8 @@ type Lens a b s t = Optic (Strong (,) ()) a b s t
 type Lens' a s = Lens a a s s
 type Prism a b s t = Optic (Strong Either Void) a b s t
 type Prism' a s = Prism a a s s
-type PTraversal a b s t = Optic PWandering a b s t
-type PTraversal' a s = PTraversal a a s s
-type DTraversal a b s t = Optic DWandering a b s t
-type DTraversal' a s = DTraversal a a s s
--- XXX: these will unify into
--- type Traversal (p :: Multiplicity) a b s t = Optic (Wandering p) a b s t
+type Traversal a b s t = Optic Traversing a b s t
+type Traversal' a s = Traversal a a s s
 
 swap :: SymmetricMonoidal m u => Iso (a `m` b) (c `m` d) (b `m` a) (d `m` c)
 swap = iso Bifunctor.swap Bifunctor.swap
@@ -97,13 +93,8 @@ _1 = Optical first
 _2 :: Lens a b (c,a) (c,b)
 _2 = Optical second
 
--- XXX: these will unify to
--- > both :: forall (p :: Multiplicity). Traversal p a b (a,a) (b,b)
-both' :: PTraversal a b (a,a) (b,b)
-both' = _Pairing .> ptraversed
-
-both :: DTraversal a b (a,a) (b,b)
-both = _Pairing .> dtraversed
+both :: Traversal a b (a,a) (b,b)
+both = _Pairing .> traversed
 
 -- XXX: these are a special case of Bitraversable, but just the simple case
 -- is included here for now
@@ -118,10 +109,6 @@ instance P.Functor Pair where
   fmap f (Paired (x,y)) = Paired (f x, f y)
 instance Functor Pair where
   fmap f (Paired (x,y)) = Paired (f x, f y)
-instance Foldable Pair where
-  foldMap f (Paired (x,y)) = f x P.<> f y
-instance P.Traversable Pair where
-  traverse f (Paired (x,y)) = Paired P.<$> ((,) P.<$> f x P.<*> f y)
 instance Traversable Pair where
   traverse f (Paired (x,y)) = Paired <$> ((,) <$> f x <*> f y)
 
@@ -140,12 +127,6 @@ _Just = prism Just (maybe (Left Nothing) Right)
 _Nothing :: Prism' () (Maybe a)
 _Nothing = prism (\() -> Nothing) Left
 
-ptraversed :: P.Traversable t => PTraversal a b (t a) (t b)
-ptraversed = Optical pwander
-
-dtraversed :: Traversable t => DTraversal a b (t a) (t b)
-dtraversed = Optical dwander
-
 over :: Optic_ LinearArrow a b s t -> (a ->. b) -> s ->. t
 over (Optical l) f = getLA (l (LA f))
 
@@ -168,7 +149,7 @@ set'' :: Optic_ (NonLinear.Kleisli (Control.Reader b)) a b s t -> b ->. s -> t
 set'' (Optical l) b s = Control.runReader (NonLinear.runKleisli (l (NonLinear.Kleisli (const (Control.reader id)))) s) b
 
 set :: Optic_ (->) a b s t -> b -> s -> t
-set (Optical l) x = l (const x)
+set l b = over' l (const b)
 
 match :: Optic_ (Market a b) a b s t -> s ->. Either t a
 match (Optical l) = snd (runMarket (l (Market id Right)))
@@ -203,3 +184,23 @@ withIso (Optical l) f = f fro to
 withPrism :: Optic_ (Market a b) a b s t -> ((b ->. t) -> (s ->. Either t a) -> r) -> r
 withPrism (Optical l) f = f b m
   where Market b m = l (Market id Right)
+
+traversal :: (s ->. Batch a b t) -> Traversal a b s t
+traversal h = Optical (\k -> dimap h fuse (traverse' k))
+
+traverse' :: (Strong Either Void arr, Monoidal (,) () arr) => a `arr` b -> Batch a c t `arr` Batch b c t
+traverse' k = dimap out inn (second (traverse' k *** k))
+
+out :: Batch a b t ->. Either t (Batch a b (b ->. t), a)
+out (P t) = Left t
+out (l :*: x) = Right (l,x)
+
+inn :: Either t (Batch a b (b ->. t), a) ->. Batch a b t
+inn (Left t) = P t
+inn (Right (l,x)) = l :*: x
+
+traversed :: Traversable t => Traversal a b (t a) (t b)
+traversed = traversal (traverse batch)
+
+withTraversal :: Optic_ (Linear.Kleisli (Batch a b)) a b s t -> s ->. Batch a b t
+withTraversal (Optical l) = Linear.runKleisli (l (Linear.Kleisli batch))
diff --git a/src/Data/Functor/Linear/Internal/Traversable.hs b/src/Data/Functor/Linear/Internal/Traversable.hs
index e8bb0232..c1a83c95 100644
--- a/src/Data/Functor/Linear/Internal/Traversable.hs
+++ b/src/Data/Functor/Linear/Internal/Traversable.hs
@@ -14,6 +14,7 @@ module Data.Functor.Linear.Internal.Traversable
     Traversable(..)
   , mapM, sequenceA, for, forM
   , mapAccumL, mapAccumR
+  , batch, runWith, Batch(..), fuse
   ) where
 
 import qualified Control.Monad.Linear.Internal as Control
@@ -79,6 +80,32 @@ instance Control.Applicative (StateR s) where
     where go :: (a, (a ->. b, s)) ->. (b, s)
           go (a, (h, s'')) = (h a, s'')
 
+data Batch a b c = P c | Batch a b (b ->. c) :*: a
+  deriving (Data.Functor, Data.Applicative) via Control.Data (Batch a b)
+instance Control.Functor (Batch a b) where
+  fmap f (P c) = P (f c)
+  fmap f (u :*: a) = Control.fmap (f.) u :*: a
+
+instance Control.Applicative (Batch a b) where
+  pure = P
+  P f <*> P x = P (f x)
+  (u :*: a) <*> P x = ((P $ help x) Control.<*> u) :*: a
+  u <*> (v :*: a) = (P (.) Control.<*> u Control.<*> v) :*: a
+
+help :: d ->. ((b ->. d ->. e) ->. b ->. e)
+help d bde b = bde b d
+
+batch :: a ->. Batch a b b
+batch x = P id :*: x
+
+runWith :: Control.Applicative f => (a ->. f b) -> Batch a b c ->. f c
+runWith _ (P x) = Control.pure x
+runWith f (u :*: x) = runWith f u Control.<*> f x
+
+fuse :: Batch b b t ->. t
+fuse (P i) = i
+fuse (u :*: x) = fuse u x
+
 ------------------------
 -- Standard instances --
 ------------------------
diff --git a/src/Data/Profunctor/Kleisli/Linear.hs b/src/Data/Profunctor/Kleisli/Linear.hs
index 6394c788..a698c5db 100644
--- a/src/Data/Profunctor/Kleisli/Linear.hs
+++ b/src/Data/Profunctor/Kleisli/Linear.hs
@@ -41,8 +41,11 @@ instance Control.Applicative f => Strong Either Void (Kleisli f) where
   first  (Kleisli f) = Kleisli (either (Data.fmap Left . f) (Control.pure . Right))
   second (Kleisli g) = Kleisli (either (Control.pure . Left) (Data.fmap Right . g))
 
-instance Control.Applicative f => DWandering (Kleisli f) where
-  dwander (Kleisli f) = Kleisli (Data.traverse f)
+instance Control.Applicative f => Monoidal (,) () (Kleisli f) where
+  Kleisli f *** Kleisli g = Kleisli $ \(x,y) -> (,) Control.<$> f x Control.<*> g y
+  unit = Kleisli Control.pure
+
+instance Control.Applicative f => Traversing (Kleisli f)
 
 -- | Linear co-Kleisli arrows for the comonad `w`. These arrows are still
 -- useful in the case where `w` is not a comonad however, and some
diff --git a/src/Data/Profunctor/Linear.hs b/src/Data/Profunctor/Linear.hs
index 6fc6a7f8..2139a93b 100644
--- a/src/Data/Profunctor/Linear.hs
+++ b/src/Data/Profunctor/Linear.hs
@@ -1,12 +1,9 @@
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -16,8 +13,7 @@ module Data.Profunctor.Linear
   ( Profunctor(..)
   , Monoidal(..)
   , Strong(..)
-  , PWandering(..)
-  , DWandering(..)
+  , Traversing
   , LinearArrow(..), getLA
   , Exchange(..)
   , Market(..), runMarket
@@ -35,7 +31,7 @@ import Control.Arrow (Kleisli(..))
 
 -- TODO: write laws
 
-class Profunctor (arr :: * -> * -> *) where
+class Profunctor arr where
   {-# MINIMAL dimap | lmap, rmap #-}
 
   dimap :: (s ->. a) -> (b ->. t) -> a `arr` b -> s `arr` t
@@ -65,17 +61,7 @@ class (SymmetricMonoidal m u, Profunctor arr) => Strong m u arr where
   second arr = dimap swap swap (first arr)
   {-# INLINE second #-}
 
--- XXX: Just as Prelude.Functor/Data.Functor will combine into
--- > `class Functor (p :: Multiplicity) f`
--- so will Traversable, and then we would instead write
--- > class (...) => Wandering (p :: Multiplicity) arr where
--- >   wander :: Traversable p f => a `arr` b -> f a `arr` f b
--- For now, however, we cannot do this, so we use two classes instead:
--- PreludeWandering and DataWandering
-class (Strong (,) () arr, Strong Either Void arr) => PWandering arr where
-  pwander :: Prelude.Traversable f => a `arr` b -> f a `arr` f b
-class (Strong (,) () arr, Strong Either Void arr) => DWandering arr where
-  dwander :: Data.Traversable f => a `arr` b -> f a `arr` f b
+class (Strong (,) () arr, Strong Either Void arr, Monoidal (,) () arr) => Traversing arr where
 
 ---------------
 -- Instances --
@@ -97,8 +83,11 @@ instance Strong Either Void LinearArrow where
   first  (LA f) = LA $ either (Left . f) Right
   second (LA g) = LA $ either Left (Right . g)
 
-instance DWandering LinearArrow where
-  dwander (LA f) = LA (Data.fmap f)
+instance Monoidal (,) () LinearArrow where
+  LA f *** LA g = LA $ \(a,x) -> (f a, g x)
+  unit = LA id
+
+instance Traversing LinearArrow
 
 instance Profunctor (->) where
   dimap f g h x = g (h (f x))
@@ -107,8 +96,10 @@ instance Strong (,) () (->) where
 instance Strong Either Void (->) where
   first f (Left x) = Left (f x)
   first _ (Right y) = Right y
-instance PWandering (->) where
-  pwander = Prelude.fmap
+instance Monoidal (,) () (->) where
+  (f *** g) (a,x) = (f a, g x)
+  unit () = ()
+instance Traversing (->)
 
 data Exchange a b s t = Exchange (s ->. a) (b ->. t)
 instance Profunctor (Exchange a b) where
@@ -126,6 +117,12 @@ instance Prelude.Applicative f => Strong Either Void (Kleisli f) where
                                    Left  x -> Prelude.fmap Left (f x)
                                    Right y -> Prelude.pure (Right y)
 
+instance Prelude.Applicative f => Monoidal (,) () (Kleisli f) where
+  Kleisli f *** Kleisli g = Kleisli (\(x,y) -> (,) Prelude.<$> f x Prelude.<*> g y)
+  unit = Kleisli Prelude.pure
+
+instance Prelude.Applicative f => Traversing (Kleisli f) where
+
 data Market a b s t = Market (b ->. t) (s ->. Either t a)
 runMarket :: Market a b s t ->. (b ->. t, s ->. Either t a)
 runMarket (Market f g) = (f, g)
@@ -136,9 +133,6 @@ instance Profunctor (Market a b) where
 instance Strong Either Void (Market a b) where
   first (Market f g) = Market (Left . f) (either (either (Left . Left) Right . g) (Left . Right))
 
-instance Prelude.Applicative f => PWandering (Kleisli f) where
-  pwander (Kleisli f) = Kleisli (Prelude.traverse f)
-
 -- TODO: pick a more sensible name for this
 newtype MyFunctor a b t = MyFunctor (b ->. (a, t))
 runMyFunctor :: MyFunctor a b t ->. b ->. (a, t)

From 0d5029f2752142bbd475393275764ba53a290afd Mon Sep 17 00:00:00 2001
From: Bhavik Mehta <bhavikmehta8@gmail.com>
Date: Fri, 13 Sep 2019 11:18:58 +0200
Subject: [PATCH 3/3] more efficient traversal

---
 src/Control/Optics/Linear/Internal.hs         | 14 +++++-----
 .../Functor/Linear/Internal/Traversable.hs    | 27 +++++++++----------
 src/Prelude/Linear.hs                         |  4 ---
 src/Prelude/Linear/Internal/Simple.hs         |  4 +++
 4 files changed, 23 insertions(+), 26 deletions(-)

diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs
index 17b5334e..2a9c3191 100644
--- a/src/Control/Optics/Linear/Internal.hs
+++ b/src/Control/Optics/Linear/Internal.hs
@@ -189,15 +189,15 @@ traversal :: (s ->. Batch a b t) -> Traversal a b s t
 traversal h = Optical (\k -> dimap h fuse (traverse' k))
 
 traverse' :: (Strong Either Void arr, Monoidal (,) () arr) => a `arr` b -> Batch a c t `arr` Batch b c t
-traverse' k = dimap out inn (second (traverse' k *** k))
+traverse' k = dimap fromBatch toBatch (second (k *** traverse' k))
 
-out :: Batch a b t ->. Either t (Batch a b (b ->. t), a)
-out (P t) = Left t
-out (l :*: x) = Right (l,x)
+fromBatch :: Batch a b t ->. Either t (a, Batch a b (b ->. t))
+fromBatch (Done t) = Left t
+fromBatch (More l x) = Right (l, x)
 
-inn :: Either t (Batch a b (b ->. t), a) ->. Batch a b t
-inn (Left t) = P t
-inn (Right (l,x)) = l :*: x
+toBatch :: Either t (a, Batch a b (b ->. t)) ->. Batch a b t
+toBatch (Left t) = Done t
+toBatch (Right (l, x)) = More l x
 
 traversed :: Traversable t => Traversal a b (t a) (t b)
 traversed = traversal (traverse batch)
diff --git a/src/Data/Functor/Linear/Internal/Traversable.hs b/src/Data/Functor/Linear/Internal/Traversable.hs
index c1a83c95..d26897bd 100644
--- a/src/Data/Functor/Linear/Internal/Traversable.hs
+++ b/src/Data/Functor/Linear/Internal/Traversable.hs
@@ -80,31 +80,28 @@ instance Control.Applicative (StateR s) where
     where go :: (a, (a ->. b, s)) ->. (b, s)
           go (a, (h, s'')) = (h a, s'')
 
-data Batch a b c = P c | Batch a b (b ->. c) :*: a
+data Batch a b c = Done c | More a (Batch a b (b ->. c))
   deriving (Data.Functor, Data.Applicative) via Control.Data (Batch a b)
+
 instance Control.Functor (Batch a b) where
-  fmap f (P c) = P (f c)
-  fmap f (u :*: a) = Control.fmap (f.) u :*: a
+  fmap f (Done c)   = Done (f c)
+  fmap f (More x l) = More x ((f.) Control.<$> l)
 
 instance Control.Applicative (Batch a b) where
-  pure = P
-  P f <*> P x = P (f x)
-  (u :*: a) <*> P x = ((P $ help x) Control.<*> u) :*: a
-  u <*> (v :*: a) = (P (.) Control.<*> u Control.<*> v) :*: a
-
-help :: d ->. ((b ->. d ->. e) ->. b ->. e)
-help d bde b = bde b d
+  pure = Done
+  Done f <*> l' = Control.fmap f l'
+  More x l <*> l' = More x (flip Control.<$> l Control.<*> l')
 
 batch :: a ->. Batch a b b
-batch x = P id :*: x
+batch x = More x (Done id)
 
 runWith :: Control.Applicative f => (a ->. f b) -> Batch a b c ->. f c
-runWith _ (P x) = Control.pure x
-runWith f (u :*: x) = runWith f u Control.<*> f x
+runWith _ (Done c) = Control.pure c
+runWith f (More x l) = runWith f l Control.<*> f x
 
 fuse :: Batch b b t ->. t
-fuse (P i) = i
-fuse (u :*: x) = fuse u x
+fuse (Done i) = i
+fuse (More x l) = fuse l x
 
 ------------------------
 -- Standard instances --
diff --git a/src/Prelude/Linear.hs b/src/Prelude/Linear.hs
index 59506ed8..c7470773 100644
--- a/src/Prelude/Linear.hs
+++ b/src/Prelude/Linear.hs
@@ -83,10 +83,6 @@ maybe _ f (Just y) = f y
 forget :: (a ->. b) ->. a -> b
 forget f x = f x
 
--- | Replacement for the flip function with generalized multiplicities.
-flip :: (a -->.(p) b -->.(q) c) -->.(r) b -->.(q) a -->.(p) c
-flip f b a = f a b
-
 -- | Linearly typed replacement for the standard '(Prelude.<*)' function.
 (<*) :: (Data.Applicative f, Consumable b) => f a ->. f b ->. f a
 fa <* fb = Data.fmap (flip lseq) fa Data.<*> fb
diff --git a/src/Prelude/Linear/Internal/Simple.hs b/src/Prelude/Linear/Internal/Simple.hs
index 167f96ac..8574c40e 100644
--- a/src/Prelude/Linear/Internal/Simple.hs
+++ b/src/Prelude/Linear/Internal/Simple.hs
@@ -56,3 +56,7 @@ foldr :: (a ->. b ->. b) -> b ->. [a] ->. b
 foldr f z = \case
   [] -> z
   x:xs -> f x (foldr f z xs)
+
+-- | Replacement for the flip function with generalized multiplicities.
+flip :: (a -->.(p) b -->.(q) c) -->.(r) b -->.(q) a -->.(p) c
+flip f b a = f a b