Add arrow-related instances (#111)

* Add several arrow-related instances: Strong: TambaraSum, PastroSum, Day Costrong: Star, TambaraSum, Rift, Ran, Codensity Choice: Day Cochoice: Rift, Ran, Codensity Category: CofreeTraversing, Costar Arrow: Star, CofreeTraversing, Coyoneda, TambaraSum ArrowZero: Star, CofreeTraversing, Yoneda, Coyoneda, TambaraSum ArrowPlus: WrappedArrow, Star, CofreeTraversing, Yoneda, Coyoneda, TambaraSum ArrowChoice: Star, CofreeTraversing, Yoneda, Coyoneda, TambaraSum ArrowApply: Star, Yoneda, Coyoneda ArrowLoop: Star, Yoneda, Coyoneda, TambaraSum * Update documentation regarding arrow instances * Update CHANGELOG.markdown --------- Co-authored-by: Ryan Scott <[email protected]>
ekmett · Jun 22, 2024 · 05bd536 · 05bd536
1 parent 6fb192d
commit 05bd536
Show file tree

Hide file tree

Showing 9 changed files with 417 additions and 7 deletions.
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
@@ -12,7 +12,36 @@
 * Re-export Data.Bifunctor.Functor's (:->) rather than supply our own
   so the two definitions do not conflict.
 * Added fixpoints of ProfunctorFunctors.
-* Add `instance Monoid r => Applicative (Forget r a)`.
+* Added `instance Monoid r => Applicative (Forget r a)`.
+* Added a number of (co)strength instances:
+  * `MonadFix f => Costrong (Star f)`
+  * `Strong p => Strong (TambaraSum p)`
+  * `Costrong p => Costrong (TambaraSum p)`
+  * `Strong p => Strong (PastroSum p)`
+  * `(Strong p, Costrong q) => Costrong (Rift p q)`
+  * `(Choice p, Cochoice q) => Cochoice (Rift p q)`
+  * `(Strong p, Costrong q) => Costrong (Ran p q)`
+  * `(Choice p, Cochoice q) => Cochoice (Ran p q)`
+  * `(Strong p, Costrong p) => Costrong (Codensity p)`
+  * `(Choice p, Cochoice p) => Cochoice (Codensity p)`
+  * `(Profunctor p, Strong q) => Strong (Day p q)`
+  * `(Choice p, Choice q) => Choice (Day p q)`
+* Added `Arrow`, `ArrowChoice`, and `ArrowLoop` instances to all types that have appropriate (co)strength.
+* Added `ArrowPlus p => ArrowPlus (WrappedArrow p)`
+* Added other arrow instances:
+  * `MonadPlus f => ArrowZero (Star f)`
+  * `MonadPlus f => ArrowPlus (Star f)`
+  * `Monad f => ArrowApply (Star f)`
+  * `(ArrowZero p, Profunctor p) => ArrowZero (CofreeTraversing p)`
+  * `(ArrowPlus p, Profunctor p) => ArrowPlus (CofreeTraversing p)`
+  * `ArrowZero p => ArrowZero (TambaraSum p)`
+  * `ArrowPlus p => ArrowPlus (TambaraSum p)`
+  * `(ArrowZero p, Profunctor p) => ArrowZero (Yoneda p)`
+  * `(ArrowPlus p, Profunctor p) => ArrowPlus (Yoneda p)`
+  * `(ArrowApply p, Profunctor p) => ArrowApply (Yoneda p)`
+  * `(ArrowZero p, Profunctor p) => ArrowZero (Coyoneda p)`
+  * `(ArrowPlus p, Profunctor p) => ArrowPlus (Coyoneda p)`
+  * `(ArrowApply p, Profunctor p) => ArrowApply (Coyoneda p)`
 
 5.6.2 [2021.02.17]
 ------------------

diff --git a/src/Data/Profunctor/Choice.hs b/src/Data/Profunctor/Choice.hs
@@ -153,6 +153,7 @@ instance Choice Tagged where
   right' = \(Tagged b) -> Tagged (Right b)
   {-# inline right' #-}
 
+-- | 'ArrowChoice' is a 'Choice' 'Arrow'.
 instance ArrowChoice p => Choice (WrappedArrow p) where
   left' = \(WrapArrow k) -> WrapArrow (left k)
   {-# inline left' #-}
@@ -199,7 +200,7 @@ instance Choice p => Choice (Tambara p) where
       hither = \case
         (Left y, s) -> Left (y, s)
         (Right z, s) -> Right (z, s)
-  
+
       yon :: Either (a, c) (b, c) -> (Either a b, c)
       yon = \case
         Left (y, s) -> (Left y, s)
@@ -231,7 +232,7 @@ instance ProfunctorComonad TambaraSum where
       hither (Left (Left x))   = Left x
       hither (Left (Right y))  = Right (Left y)
       hither (Right z)         = Right (Right z)
-  
+
       yon    :: Either a (Either b c) -> Either (Either a b) c
       yon    (Left x)          = Left (Left x)
       yon    (Right (Left y))  = Left (Right y)
@@ -247,11 +248,99 @@ instance Profunctor p => Choice (TambaraSum p) where
   left' = \p -> runTambaraSum $ produplicate p
   {-# inline left' #-}
 
+instance Strong p => Strong (TambaraSum p) where
+  first' (TambaraSum f) = TambaraSum $ dimap hither yon $ first' f
+    where
+      hither :: Either (a, b) c -> (Either a c, Either b c)
+      hither (Left (a, b)) = (Left a, Left b)
+      hither (Right c) = (Right c, Right c)
+
+      yon :: (Either a c, Either b c) -> Either (a, b) c
+      yon (Left a, Left b) = Left (a, b)
+      yon (Right c, _) = Right c
+      yon (_, Right c) = Right c
+  {-# INLINE first' #-}
+
+  second' (TambaraSum f) = TambaraSum $ dimap hither yon $ second' f
+    where
+      hither :: Either (a, b) c -> (Either a c, Either b c)
+      hither (Left (a, b)) = (Left a, Left b)
+      hither (Right c) = (Right c, Right c)
+
+      yon :: (Either a c, Either b c) -> Either (a, b) c
+      yon (Left a, Left b) = Left (a, b)
+      yon (Right c, _) = Right c
+      yon (_, Right c) = Right c
+  {-# INLINE second' #-}
+
+instance Costrong p => Costrong (TambaraSum p) where
+  unfirst (TambaraSum f) = TambaraSum $ unfirst $ dimap hither yon f
+    where
+      hither :: (Either a c, Either b c) -> Either (a, b) c
+      hither (Left a, Left b) = Left (a, b)
+      hither (Right c, _) = Right c
+      hither (_, Right c) = Right c
+
+      yon :: Either (a, b) c -> (Either a c, Either b c)
+      yon (Left (a, b)) = (Left a, Left b)
+      yon (Right c) = (Right c, Right c)
+  {-# INLINE unfirst #-}
+
+  unsecond (TambaraSum f) = TambaraSum $ unsecond $ dimap hither yon f
+    where
+      hither :: (Either a c, Either b c) -> Either (a, b) c
+      hither (Left a, Left b) = Left (a, b)
+      hither (Right c, _) = Right c
+      hither (_, Right c) = Right c
+
+      yon :: Either (a, b) c -> (Either a c, Either b c)
+      yon (Left (a, b)) = (Left a, Left b)
+      yon (Right c) = (Right c, Right c)
+  {-# INLINE unsecond #-}
+
 instance Category p => Category (TambaraSum p) where
   id = TambaraSum id
   (.) = \(TambaraSum p) (TambaraSum q) -> TambaraSum (p . q)
   {-# inline (.) #-}
 
+instance Arrow p => Arrow (TambaraSum p) where
+  arr f = promap unwrapArrow $ lmap f id
+  {-# INLINE arr #-}
+  first (TambaraSum f) = promap unwrapArrow $ first' (TambaraSum $ WrapArrow f)
+  {-# INLINE first #-}
+  second (TambaraSum f) = promap unwrapArrow $ second' (TambaraSum $ WrapArrow f)
+  {-# INLINE second #-}
+  TambaraSum f *** TambaraSum g = promap unwrapArrow
+    $ splitStrong (TambaraSum $ WrapArrow f) (TambaraSum $ WrapArrow g)
+  {-# INLINE (***) #-}
+  TambaraSum f &&& TambaraSum g = promap unwrapArrow
+    $ fanOut (TambaraSum $ WrapArrow f) (TambaraSum $ WrapArrow g)
+  {-# INLINE (&&&) #-}
+
+instance ArrowZero p => ArrowZero (TambaraSum p) where
+  zeroArrow = TambaraSum zeroArrow
+  {-# INLINE zeroArrow #-}
+
+instance ArrowPlus p => ArrowPlus (TambaraSum p) where
+  TambaraSum p <+> TambaraSum q = TambaraSum (p <+> q)
+  {-# INLINE (<+>) #-}
+
+instance Arrow p => ArrowChoice (TambaraSum p) where
+  left (TambaraSum f) = promap unwrapArrow $ left' (TambaraSum $ WrapArrow f)
+  {-# INLINE left #-}
+  right (TambaraSum f) = promap unwrapArrow $ right' (TambaraSum $ WrapArrow f)
+  {-# INLINE right #-}
+  TambaraSum f +++ TambaraSum g = promap unwrapArrow
+    $ splitChoice (TambaraSum $ WrapArrow f) (TambaraSum $ WrapArrow g)
+  {-# INLINE (+++) #-}
+  TambaraSum f ||| TambaraSum g = promap unwrapArrow
+    $ fanIn (TambaraSum $ WrapArrow f) (TambaraSum $ WrapArrow g)
+  {-# INLINE (|||) #-}
+
+instance (Arrow p, Costrong p) => ArrowLoop (TambaraSum p) where
+  loop = unfirst
+  {-# INLINE loop #-}
+
 instance Profunctor p => Functor (TambaraSum p a) where
   fmap = rmap
 
@@ -310,7 +399,7 @@ instance ProfunctorFunctor PastroSum where
 instance ProfunctorMonad PastroSum where
   proreturn = \p -> PastroSum fromEither p Left
   projoin = \(PastroSum l (PastroSum m n o) q) ->
-    let 
+    let
       oq a = case q a of
         Left b -> Left <$> o b
         Right z -> Right (Right z)
@@ -326,13 +415,35 @@ instance Choice (PastroSum p) where
       l' (Right (Left z))  = Left (l (Right z))
       l' (Right (Right c)) = Right c
     in PastroSum l' m r'
-  right' = \(PastroSum l m r) -> let 
+
+  right' = \(PastroSum l m r) -> let
       r' = either (Right . Left) (fmap Right . r)
       l' (Right (Left c))  = Left c
       l' (Right (Right z)) = Right (l (Right z))
       l' (Left y)          = Right (l (Left y))
     in PastroSum l' m r'
 
+instance Strong p => Strong (PastroSum p) where
+  first' (PastroSum l m r) = PastroSum l' m' r'
+    where
+      l' (Left (a, c)) = (l (Left a), c)
+      l' (Right (b, c)) = (l (Right b), c)
+      m' = first' m
+      r' (e, c) = case r e of
+        Left a -> Left (a, c)
+        Right b -> Right (b, c)
+  {-# INLINE first' #-}
+
+  second' (PastroSum l m r) = PastroSum l' m' r'
+    where
+      l' (Left (c, a)) = (c, l (Left a))
+      l' (Right (c, b)) = (c, l (Right b))
+      m' = second' m
+      r' (c, e) = case r e of
+        Left a -> Left (c, a)
+        Right b -> Right (c, b)
+  {-# INLINE second' #-}
+
 --------------------------------------------------------------------------------
 -- * Costrength for Either
 --------------------------------------------------------------------------------

diff --git a/src/Data/Profunctor/Composition.hs b/src/Data/Profunctor/Composition.hs
@@ -252,6 +252,18 @@ instance p ~ q => Category (Rift p q) where
   Rift f . Rift g = Rift (g . f)
   {-# INLINE (.) #-}
 
+instance (Strong p, Costrong q) => Costrong (Rift p q) where
+  unfirst (Rift h) = Rift $ unfirst . h . first'
+  {-# INLINE unfirst #-}
+  unsecond (Rift h) = Rift $ unsecond . h . second'
+  {-# INLINE unsecond #-}
+
+instance (Choice p, Cochoice q) => Cochoice (Rift p q) where
+  unleft (Rift h) = Rift $ unleft . h . left'
+  {-# INLINE unleft #-}
+  unright (Rift h) = Rift $ unright . h . right'
+  {-# INLINE unright #-}
+
 -- | The 2-morphism that defines a left Kan lift.
 --
 -- Note: When @p@ is right adjoint to @'Rift' p (->)@ then 'decomposeRift' is the 'counit' of the adjunction.

diff --git a/src/Data/Profunctor/Day.hs b/src/Data/Profunctor/Day.hs
@@ -82,6 +82,55 @@ instance Monoidal p => ProfunctorMonad (Day p) where
       q
   {-# inline projoin #-}
 
+-- | Use @q@'s strength. To use @p@'s strength see 'swapped'.
+instance (Profunctor p, Strong q) => Strong (Day p q) where
+  first' (Day f g p q) = Day
+    (\(f -> (a, c), x) -> (a, (c, x)))
+    (\(b, (d, x)) -> (g (b, d), x))
+    p
+    (first' q)
+  {-# INLINE first' #-}
+
+  second' (Day f g p q) = Day
+    (\(x, f -> (a, c)) -> (a, (x, c)))
+    (\(b, (x, d)) -> (x, g (b, d)))
+    p
+    (second' q)
+  {-# INLINE second' #-}
+
+instance (Choice p, Choice q) => Choice (Day p q) where
+  left' (Day f g p q) = Day
+    (hither . left' f)
+    (left' g . yon)
+    (left' p)
+    (left' q)
+    where
+      hither :: Either (a, b) c -> (Either a c, Either b c)
+      hither (Left (a, b)) = (Left a, Left b)
+      hither (Right c) = (Right c, Right c)
+
+      yon :: (Either a c, Either b c) -> Either (a, b) c
+      yon (Left a, Left b) = Left (a, b)
+      yon (Right c, _) = Right c
+      yon (_, Right c) = Right c
+  {-# INLINE left' #-}
+
+  right' (Day f g p q) = Day
+    (hither . right' f)
+    (right' g . yon)
+    (right' p)
+    (right' q)
+    where
+      hither :: Either c (a, b) -> (Either c a, Either c b)
+      hither (Right (a, b)) = (Right a, Right b)
+      hither (Left c) = (Left c, Left c)
+
+      yon :: (Either c a, Either c b) -> Either c (a, b)
+      yon (Right a, Right b) = Right (a, b)
+      yon (Left c, _) = Left c
+      yon (_, Left c) = Left c
+  {-# INLINE right' #-}
+
 assoc :: Day (Day p q) r :-> Day p (Day q r)
 assoc = \(Day i h (Day g f p q) r) -> Day
   (\(i -> (g -> (a1,c1), c)) -> (a1, (c1, c)))

diff --git a/src/Data/Profunctor/Ran.hs b/src/Data/Profunctor/Ran.hs
@@ -76,6 +76,18 @@ instance p ~ q => Category (Ran p q) where
   Ran f . Ran g = Ran (f . g)
   {-# INLINE (.) #-}
 
+instance (Strong p, Costrong q) => Costrong (Ran p q) where
+  unfirst (Ran h) = Ran $ unfirst . h . first'
+  {-# INLINE unfirst #-}
+  unsecond (Ran h) = Ran $ unsecond . h . second'
+  {-# INLINE unsecond #-}
+
+instance (Choice p, Cochoice q) => Cochoice (Ran p q) where
+  unleft (Ran h) = Ran $ unleft . h . left'
+  {-# INLINE unleft #-}
+  unright (Ran h) = Ran $ unright . h . right'
+  {-# INLINE unright #-}
+
 -- | The 2-morphism that defines a right Kan extension.
 --
 -- Note: When @q@ is left adjoint to @'Ran' q (->)@ then 'decomposeRan' is the 'counit' of the adjunction.
@@ -130,6 +142,18 @@ instance Category (Codensity p) where
   Codensity f . Codensity g = Codensity (f . g)
   {-# INLINE (.) #-}
 
+instance (Strong p, Costrong p) => Costrong (Codensity p) where
+  unfirst (Codensity h) = Codensity $ unfirst . h . first'
+  {-# INLINE unfirst #-}
+  unsecond (Codensity h) = Codensity $ unsecond . h . second'
+  {-# INLINE unsecond #-}
+
+instance (Choice p, Cochoice p) => Cochoice (Codensity p) where
+  unleft (Codensity h) = Codensity $ unleft . h . left'
+  {-# INLINE unleft #-}
+  unright (Codensity h) = Codensity $ unright . h . right'
+  {-# INLINE unright #-}
+
 decomposeCodensity :: Procompose (Codensity p) p a b -> p a b
 decomposeCodensity (Procompose (Codensity pp) p) = pp p
 {-# INLINE decomposeCodensity #-}
diff --git a/src/Data/Profunctor/Strong.hs b/src/Data/Profunctor/Strong.hs
@@ -380,6 +380,12 @@ instance Costrong (->) where
   unfirst f a = b where (b, d) = f (a, d)
   unsecond f a = b where (d, b) = f (d, a)
 
+instance MonadFix f => Costrong (Star f) where
+  unfirst (Star f) = Star $ \x -> fst <$> mfix (\ ~(_, y) -> f (x, y))
+  {-# INLINE unfirst #-}
+  unsecond (Star f) = Star $ \x -> snd <$> mfix (\ ~(y, _) -> f (y, x))
+  {-# INLINE unsecond #-}
+
 instance Functor f => Costrong (Costar f) where
   unfirst (Costar f) = Costar f'
     where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)
@@ -390,6 +396,7 @@ instance Costrong Tagged where
   unfirst (Tagged bd) = Tagged (fst bd)
   unsecond (Tagged db) = Tagged (snd db)
 
+-- | 'ArrowLoop' is a 'Costrong' 'Arrow'.
 instance ArrowLoop p => Costrong (WrappedArrow p) where
   unfirst (WrapArrow k) = WrapArrow (loop k)