{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} module Control.Arrow.Profunctor where import Data.Profunctor import qualified Data.Profunctor.Arrow as PA import qualified Control.Arrow as Arr import qualified Control.Category as C import Data.Coerce import Data.Bifunctor newtype WrappedProfunctor p a b = WrappedProfunctor {WrappedProfunctor p a b -> p a b unwrapProfunctor :: p a b} deriving newtype WrappedProfunctor p a a WrappedProfunctor p b c -> WrappedProfunctor p a b -> WrappedProfunctor p a c (forall a. WrappedProfunctor p a a) -> (forall b c a. WrappedProfunctor p b c -> WrappedProfunctor p a b -> WrappedProfunctor p a c) -> Category (WrappedProfunctor p) forall a. WrappedProfunctor p a a forall b c a. WrappedProfunctor p b c -> WrappedProfunctor p a b -> WrappedProfunctor p a c forall k (cat :: k -> k -> *). (forall (a :: k). cat a a) -> (forall (b :: k) (c :: k) (a :: k). cat b c -> cat a b -> cat a c) -> Category cat forall (p :: * -> * -> *) a. Category p => WrappedProfunctor p a a forall (p :: * -> * -> *) b c a. Category p => WrappedProfunctor p b c -> WrappedProfunctor p a b -> WrappedProfunctor p a c . :: WrappedProfunctor p b c -> WrappedProfunctor p a b -> WrappedProfunctor p a c $c. :: forall (p :: * -> * -> *) b c a. Category p => WrappedProfunctor p b c -> WrappedProfunctor p a b -> WrappedProfunctor p a c id :: WrappedProfunctor p a a $cid :: forall (p :: * -> * -> *) a. Category p => WrappedProfunctor p a a C.Category instance (Profunctor p, C.Category p, Strong p) => Arr.Arrow (WrappedProfunctor p) where arr :: (b -> c) -> WrappedProfunctor p b c arr = p b c -> WrappedProfunctor p b c forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c -> WrappedProfunctor p b c) -> ((b -> c) -> p b c) -> (b -> c) -> WrappedProfunctor p b c forall b c a. (b -> c) -> (a -> b) -> a -> c . (b -> c) -> p b c forall (p :: * -> * -> *) a b. (Profunctor p, Category p) => (a -> b) -> p a b PA.arr first :: WrappedProfunctor p b c -> WrappedProfunctor p (b, d) (c, d) first (WrappedProfunctor p :: p b c p) = p (b, d) (c, d) -> WrappedProfunctor p (b, d) (c, d) forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c -> p (b, d) (c, d) forall (p :: * -> * -> *) a b c. Strong p => p a b -> p (a, c) (b, c) first' p b c p) second :: WrappedProfunctor p b c -> WrappedProfunctor p (d, b) (d, c) second (WrappedProfunctor p :: p b c p) = p (d, b) (d, c) -> WrappedProfunctor p (d, b) (d, c) forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c -> p (d, b) (d, c) forall (p :: * -> * -> *) a b c. Strong p => p a b -> p (c, a) (c, b) second' p b c p) WrappedProfunctor l :: p b c l *** :: WrappedProfunctor p b c -> WrappedProfunctor p b' c' -> WrappedProfunctor p (b, b') (c, c') *** WrappedProfunctor r :: p b' c' r = p (b, b') (c, c') -> WrappedProfunctor p (b, b') (c, c') forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c l p b c -> p b' c' -> p (b, b') (c, c') forall (p :: * -> * -> *) b c b' c'. (Category p, Strong p) => p b c -> p b' c' -> p (b, b') (c, c') PA.*** p b' c' r) WrappedProfunctor l :: p b c l &&& :: WrappedProfunctor p b c -> WrappedProfunctor p b c' -> WrappedProfunctor p b (c, c') &&& WrappedProfunctor r :: p b c' r = p b (c, c') -> WrappedProfunctor p b (c, c') forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c l p b c -> p b c' -> p b (c, c') forall (p :: * -> * -> *) b c c'. (Category p, Strong p) => p b c -> p b c' -> p b (c, c') PA.&&& p b c' r) instance (PA.ProfunctorZero p, C.Category p, Strong p) => Arr.ArrowZero (WrappedProfunctor p) where zeroArrow :: WrappedProfunctor p b c zeroArrow = p b c -> WrappedProfunctor p b c forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor p b c forall (p :: * -> * -> *) a b. ProfunctorZero p => p a b PA.zeroProfunctor instance (PA.ProfunctorPlus p, C.Category p, Strong p) => Arr.ArrowPlus (WrappedProfunctor p) where WrappedProfunctor l :: p b c l <+> :: WrappedProfunctor p b c -> WrappedProfunctor p b c -> WrappedProfunctor p b c <+> WrappedProfunctor r :: p b c r = p b c -> WrappedProfunctor p b c forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c l p b c -> p b c -> p b c forall (p :: * -> * -> *) a b. ProfunctorPlus p => p a b -> p a b -> p a b PA.<+> p b c r) instance (Choice p, C.Category p, Strong p) => Arr.ArrowChoice (WrappedProfunctor p) where left :: WrappedProfunctor p b c -> WrappedProfunctor p (Either b d) (Either c d) left (WrappedProfunctor l :: p b c l) = p (Either b d) (Either c d) -> WrappedProfunctor p (Either b d) (Either c d) forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c -> p (Either b d) (Either c d) forall (p :: * -> * -> *) a b c. Choice p => p a b -> p (Either a c) (Either b c) left' p b c l) right :: WrappedProfunctor p b c -> WrappedProfunctor p (Either d b) (Either d c) right (WrappedProfunctor l :: p b c l) = p (Either d b) (Either d c) -> WrappedProfunctor p (Either d b) (Either d c) forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c -> p (Either d b) (Either d c) forall (p :: * -> * -> *) a b c. Choice p => p a b -> p (Either c a) (Either c b) right' p b c l) WrappedProfunctor l :: p b c l +++ :: WrappedProfunctor p b c -> WrappedProfunctor p b' c' -> WrappedProfunctor p (Either b b') (Either c c') +++ WrappedProfunctor r :: p b' c' r = p (Either b b') (Either c c') -> WrappedProfunctor p (Either b b') (Either c c') forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b c l p b c -> p b' c' -> p (Either b b') (Either c c') forall (p :: * -> * -> *) b c b' c'. (Choice p, Category p) => p b c -> p b' c' -> p (Either b b') (Either c c') PA.+++ p b' c' r) WrappedProfunctor l :: p b d l ||| :: WrappedProfunctor p b d -> WrappedProfunctor p c d -> WrappedProfunctor p (Either b c) d ||| WrappedProfunctor r :: p c d r = p (Either b c) d -> WrappedProfunctor p (Either b c) d forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p b d l p b d -> p c d -> p (Either b c) d forall (p :: * -> * -> *) b d c. (Choice p, Category p) => p b d -> p c d -> p (Either b c) d PA.||| p c d r) instance (C.Category p, Strong p, PA.ProfunctorApply p) => Arr.ArrowApply (WrappedProfunctor p) where app :: WrappedProfunctor p (WrappedProfunctor p b c, b) c app = p (WrappedProfunctor p b c, b) c -> WrappedProfunctor p (WrappedProfunctor p b c, b) c forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (((WrappedProfunctor p b c, b) -> (p b c, b)) -> p (p b c, b) c -> p (WrappedProfunctor p b c, b) c forall (p :: * -> * -> *) a b c. Profunctor p => (a -> b) -> p b c -> p a c lmap ((WrappedProfunctor p b c -> p b c) -> (WrappedProfunctor p b c, b) -> (p b c, b) forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first WrappedProfunctor p b c -> p b c forall a b. Coercible a b => a -> b coerce) p (p b c, b) c forall (p :: * -> * -> *) a b. ProfunctorApply p => p (p a b, a) b PA.app) instance (C.Category p, Strong p, Costrong p) => Arr.ArrowLoop (WrappedProfunctor p) where loop :: WrappedProfunctor p (b, d) (c, d) -> WrappedProfunctor p b c loop (WrappedProfunctor p :: p (b, d) (c, d) p) = p b c -> WrappedProfunctor p b c forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b WrappedProfunctor (p (b, d) (c, d) -> p b c forall (p :: * -> * -> *) a d b. Costrong p => p (a, d) (b, d) -> p a b unfirst p (b, d) (c, d) p)