From 05bd536a8e7e8299fd8320355cc4b6b816e07df8 Mon Sep 17 00:00:00 2001 From: mniip Date: Sat, 22 Jun 2024 19:41:01 +0200 Subject: [PATCH] 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 --- CHANGELOG.markdown | 31 +++++++- src/Data/Profunctor/Choice.hs | 119 ++++++++++++++++++++++++++++- src/Data/Profunctor/Composition.hs | 12 +++ src/Data/Profunctor/Day.hs | 49 ++++++++++++ src/Data/Profunctor/Ran.hs | 24 ++++++ src/Data/Profunctor/Strong.hs | 7 ++ src/Data/Profunctor/Traversing.hs | 40 +++++++++- src/Data/Profunctor/Types.hs | 55 ++++++++++++- src/Data/Profunctor/Yoneda.hs | 87 +++++++++++++++++++++ 9 files changed, 417 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown index e4e4f6f6..625b89fc 100644 --- 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 index 8c922c2a..2e27786c 100644 --- 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 index 52559c7d..4b6cf23f 100644 --- 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 index 433fd7a6..5b7f41aa 100644 --- 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 index 48da1824..62333d48 100644 --- 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 index 935d099e..347261af 100644 --- 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) diff --git a/src/Data/Profunctor/Traversing.hs b/src/Data/Profunctor/Traversing.hs index 98a7bf66..98ccf443 100644 --- a/src/Data/Profunctor/Traversing.hs +++ b/src/Data/Profunctor/Traversing.hs @@ -22,7 +22,8 @@ module Data.Profunctor.Traversing ) where import Control.Applicative -import Control.Arrow (Kleisli(..)) +import Control.Arrow +import Control.Category import Data.Bifunctor.Tannen import Data.Functor.Compose import Data.Functor.Identity @@ -35,6 +36,7 @@ import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Traversable import Data.Tuple (swap) +import Prelude hiding ((.), id) firstTraversing :: Traversing p => p a b -> p (a, c) (b, c) firstTraversing = dimap swap swap . traverse' @@ -168,6 +170,42 @@ instance ProfunctorComonad CofreeTraversing where proextract (CofreeTraversing p) = runIdentity #. p .# Identity produplicate (CofreeTraversing p) = CofreeTraversing (CofreeTraversing (dimap Compose getCompose p)) +instance Category p => Category (CofreeTraversing p) where + id = CofreeTraversing id + {-# INLINE id #-} + CofreeTraversing f . CofreeTraversing g = CofreeTraversing (f . g) + {-# INLINE (.) #-} + +instance (Category p, Profunctor p) => Arrow (CofreeTraversing p) where + arr f = lmap f id + {-# INLINE arr #-} + first = first' + {-# INLINE first #-} + second = second' + {-# INLINE second #-} + (***) = splitStrong + {-# INLINE (***) #-} + (&&&) = fanOut + {-# INLINE (&&&) #-} + +instance (ArrowZero p, Profunctor p) => ArrowZero (CofreeTraversing p) where + zeroArrow = CofreeTraversing zeroArrow + {-# INLINE zeroArrow #-} + +instance (ArrowPlus p, Profunctor p) => ArrowPlus (CofreeTraversing p) where + CofreeTraversing f <+> CofreeTraversing g = CofreeTraversing (f <+> g) + {-# INLINE (<+>) #-} + +instance (Category p, Profunctor p) => ArrowChoice (CofreeTraversing p) where + left = left' + {-# INLINE left #-} + right = right' + {-# INLINE right #-} + (+++) = splitChoice + {-# INLINE (+++) #-} + (|||) = fanIn + {-# INLINE (|||) #-} + -- | @FreeTraversing -| CofreeTraversing@ data FreeTraversing p a b where FreeTraversing :: Traversable f => (f y -> b) -> p x y -> (a -> f x) -> FreeTraversing p a b diff --git a/src/Data/Profunctor/Types.hs b/src/Data/Profunctor/Types.hs index e37ad020..44676b8f 100644 --- a/src/Data/Profunctor/Types.hs +++ b/src/Data/Profunctor/Types.hs @@ -34,6 +34,7 @@ import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (MonadPlus(..), (>=>)) +import Control.Monad.Fix import Data.Bifunctor.Functor ((:->)) import Data.Coerce (Coercible, coerce) import Data.Foldable @@ -93,6 +94,40 @@ instance Monad f => Category (Star f) where id = Star return Star f . Star g = Star $ g >=> f +instance Monad f => Arrow (Star f) where + arr f = Star (pure . f) + {-# INLINE arr #-} + first (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a + {-# INLINE first #-} + second (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a + {-# INLINE second #-} + Star f *** Star g = Star $ \ ~(x, y) -> liftA2 (flip (,)) (g y) (f x) + {-# INLINE (***) #-} + Star f &&& Star g = Star $ \ x -> liftA2 (flip (,)) (g x) (f x) + {-# INLINE (&&&) #-} + +instance MonadPlus f => ArrowZero (Star f) where + zeroArrow = Star $ \_ -> mzero + {-# INLINE zeroArrow #-} + +instance MonadPlus f => ArrowPlus (Star f) where + Star f <+> Star g = Star $ \x -> mplus (f x) (g x) + {-# INLINE (<+>) #-} + +instance Monad f => ArrowChoice (Star f) where + left (Star f) = Star $ either (fmap Left . f) (pure . Right) + {-# INLINE left #-} + right (Star f) = Star $ either (pure . Left) (fmap Right . f) + {-# INLINE right #-} + +instance Monad f => ArrowApply (Star f) where + app = Star $ \ ~(Star f, x) -> f x + {-# INLINE app #-} + +instance MonadFix f => ArrowLoop (Star f) where + loop (Star f) = Star $ \x -> fst <$> mfix (\ ~(_, y) -> f (x, y)) + {-# INLINE loop #-} + instance Contravariant f => Contravariant (Star f a) where contramap f (Star g) = Star (contramap f . g) {-# INLINE contramap #-} @@ -136,11 +171,25 @@ instance Monad (Costar f a) where return = pure Costar m >>= f = Costar $ \ x -> runCostar (f (m x)) x +instance Comonad f => Category (Costar f) where + id = Costar extract + {-# INLINE id #-} + Costar f . Costar g = Costar (f =<= g) + {-# INLINE (.) #-} + ------------------------------------------------------------------------------ -- Wrapped Profunctors ------------------------------------------------------------------------------ --- | Wrap an arrow for use as a 'Profunctor'. +-- | This newtype allows 'Profunctor' classes to be used with types that only +-- implement @base@'s arrow classes. +-- +-- - 'Arrow' is equivalent to 'Category' +-- && t'Data.Profunctor.Strong.Strong'. +-- - 'ArrowChoice' is equivalent to 'Category' +-- && t'Data.Profunctor.Strong.Strong' && t'Data.Profunctor.Choice.Choice'. +-- - 'ArrowLoop' is equivalent to 'Category' +-- && t'Data.Profunctor.Strong.Strong' && t'Data.Profunctor.Strong.Costrong'. -- -- 'WrappedArrow' has a polymorphic kind since @5.6@. @@ -173,6 +222,10 @@ instance ArrowZero p => ArrowZero (WrappedArrow p) where zeroArrow = WrapArrow zeroArrow {-# INLINE zeroArrow #-} +instance ArrowPlus p => ArrowPlus (WrappedArrow p) where + WrapArrow p <+> WrapArrow q = WrapArrow (p <+> q) + {-# INLINE (<+>) #-} + instance ArrowChoice p => ArrowChoice (WrappedArrow p) where left = WrapArrow . left . unwrapArrow {-# INLINE left #-} diff --git a/src/Data/Profunctor/Yoneda.hs b/src/Data/Profunctor/Yoneda.hs index be184e40..1413d0b4 100644 --- a/src/Data/Profunctor/Yoneda.hs +++ b/src/Data/Profunctor/Yoneda.hs @@ -18,11 +18,14 @@ module Data.Profunctor.Yoneda , Coyoneda(..), returnCoyoneda, joinCoyoneda ) where +import Control.Arrow import Control.Category import Data.Coerce (Coercible, coerce) import Data.Profunctor +import Data.Profunctor.Choice import Data.Profunctor.Functor import Data.Profunctor.Monad +import Data.Profunctor.Strong import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding (id,(.)) @@ -121,6 +124,48 @@ instance Traversing p => Traversing (Yoneda p) where wander f = proreturn . wander f . extractYoneda {-# INLINE wander #-} +instance (Arrow p, Profunctor p) => Arrow (Yoneda p) where + arr f = lmap f id + {-# INLINE arr #-} + first = promap unwrapArrow . first' . promap WrapArrow + {-# INLINE first #-} + second = promap unwrapArrow . second' . promap WrapArrow + {-# INLINE second #-} + p *** q = promap unwrapArrow $ + splitStrong (promap WrapArrow p) (promap WrapArrow q) + {-# INLINE (***) #-} + p &&& q = promap unwrapArrow $ + fanOut (promap WrapArrow p) (promap WrapArrow q) + {-# INLINE (&&&) #-} + +instance (ArrowZero p, Profunctor p) => ArrowZero (Yoneda p) where + zeroArrow = proreturn zeroArrow + {-# INLINE zeroArrow #-} + +instance (ArrowPlus p, Profunctor p) => ArrowPlus (Yoneda p) where + p <+> q = proreturn (extractYoneda p <+> extractYoneda q) + {-# INLINE (<+>) #-} + +instance (ArrowChoice p, Profunctor p) => ArrowChoice (Yoneda p) where + left = promap unwrapArrow . left' . promap WrapArrow + {-# INLINE left #-} + right = promap unwrapArrow . right' . promap WrapArrow + {-# INLINE right #-} + p +++ q = promap unwrapArrow + (splitChoice (promap WrapArrow p) (promap WrapArrow q)) + {-# INLINE (+++) #-} + p ||| q = promap unwrapArrow + (fanIn (promap WrapArrow p) (promap WrapArrow q)) + {-# INLINE (|||) #-} + +instance (ArrowApply p, Profunctor p) => ArrowApply (Yoneda p) where + app = proreturn $ lmap (first extractYoneda) app + {-# INLINE app #-} + +instance (ArrowLoop p, Profunctor p) => ArrowLoop (Yoneda p) where + loop = promap unwrapArrow . unfirst . promap WrapArrow + {-# INLINE loop #-} + -------------------------------------------------------------------------------- -- * Coyoneda -------------------------------------------------------------------------------- @@ -214,3 +259,45 @@ instance Traversing p => Traversing (Coyoneda p) where {-# INLINE traverse' #-} wander f = returnCoyoneda . wander f . proextract {-# INLINE wander #-} + +instance (Arrow p, Profunctor p) => Arrow (Coyoneda p) where + arr f = lmap f id + {-# INLINE arr #-} + first = promap unwrapArrow . first' . promap WrapArrow + {-# INLINE first #-} + second = promap unwrapArrow . second' . promap WrapArrow + {-# INLINE second #-} + p *** q = promap unwrapArrow $ + splitStrong (promap WrapArrow p) (promap WrapArrow q) + {-# INLINE (***) #-} + p &&& q = promap unwrapArrow $ + fanOut (promap WrapArrow p) (promap WrapArrow q) + {-# INLINE (&&&) #-} + +instance (ArrowZero p, Profunctor p) => ArrowZero (Coyoneda p) where + zeroArrow = returnCoyoneda zeroArrow + {-# INLINE zeroArrow #-} + +instance (ArrowPlus p, Profunctor p) => ArrowPlus (Coyoneda p) where + p <+> q = returnCoyoneda (proextract p <+> proextract q) + {-# INLINE (<+>) #-} + +instance (ArrowChoice p, Profunctor p) => ArrowChoice (Coyoneda p) where + left = promap unwrapArrow . left' . promap WrapArrow + {-# INLINE left #-} + right = promap unwrapArrow . right' . promap WrapArrow + {-# INLINE right #-} + p +++ q = promap unwrapArrow $ + splitChoice (promap WrapArrow p) (promap WrapArrow q) + {-# INLINE (+++) #-} + p ||| q = promap unwrapArrow $ + fanIn (promap WrapArrow p) (promap WrapArrow q) + {-# INLINE (|||) #-} + +instance (ArrowApply p, Profunctor p) => ArrowApply (Coyoneda p) where + app = returnCoyoneda $ lmap (first proextract) app + {-# INLINE app #-} + +instance (ArrowLoop p, Profunctor p) => ArrowLoop (Coyoneda p) where + loop = promap unwrapArrow . unfirst . promap WrapArrow + {-# INLINE loop #-}