Batch traversals

Author: b-mehta

src/Control/Optics/Linear/Internal.hs

@@ -13,17 +13,16 @@ module Control.Optics.Linear.Internal
   , Iso, Iso'
   , Lens, Lens'
   , Prism, Prism'
-  , PTraversal, PTraversal'
-  , DTraversal, DTraversal'
+  , Traversal, Traversal'
     -- * Composing optics
   , (.>)
     -- * Common optics
   , swap, assoc
   , _1, _2
   , _Left, _Right
   , _Just, _Nothing
-  , ptraversed, dtraversed
-  , both, both'
+  , traversed
+  , both
     -- * Using optics
   , get, set, gets
   , set', set''
@@ -32,8 +31,8 @@ module Control.Optics.Linear.Internal
   , over, over'
   , traverseOf, traverseOf'
   , lengthOf
-  , withIso, withLens, withPrism
   , toListOf
+  , withIso, withLens, withPrism, withTraversal
     -- * Constructing optics
   , iso, prism, lens
   )
@@ -42,6 +41,7 @@ module Control.Optics.Linear.Internal
 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
@@ -140,12 +131,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))
 
@@ -203,3 +188,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))

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 --
 ------------------------

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

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,8 +133,11 @@ 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)
+-- instance Control.Functor (Const (Top, a)) where
+--   fmap f (Const (t, x)) = Const (throw f <> t, x)
+-- instance Monoid a => Control.Applicative (Const (Top, a)) where
+--   pure x = Const (throw x, mempty)
+--   Const x <*> Const y = Const (x <> y)
 
 -- TODO: pick a more sensible name for this
 newtype MyFunctor a b t = MyFunctor (b ->. (a, t))