{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.Profunctor.Strong
(
Strong(..)
, uncurry'
, strong
, Tambara(..)
, tambara, untambara
, Pastro(..)
, pastro, unpastro
, Costrong(..)
, Cotambara(..)
, cotambara, uncotambara
, Copastro(..)
) where
import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Category
import Control.Comonad
import Control.Monad (liftM)
import Control.Monad.Fix
import Data.Bifunctor.Clown (Clown(..))
import Data.Bifunctor.Product (Product(..))
import Data.Bifunctor.Sum (Sum(..))
import Data.Bifunctor.Tannen (Tannen(..))
import Data.Functor.Contravariant (Contravariant(..))
import Data.Profunctor.Adjunction
import Data.Profunctor.Monad
import Data.Profunctor.Types
import Data.Profunctor.Unsafe
import Data.Semigroup hiding (Product, Sum)
import Data.Tagged
import Data.Tuple
import Prelude hiding (id,(.))
class Profunctor p => Strong p where
first' :: p a b -> p (a, c) (b, c)
first' = dimap swap swap . second'
second' :: p a b -> p (c, a) (c, b)
second' = dimap swap swap . first'
{-# MINIMAL first' | second' #-}
uncurry' :: Strong p => p a (b -> c) -> p (a, b) c
uncurry' = rmap (\(f,x) -> f x) . first'
{-# INLINE uncurry' #-}
strong :: Strong p => (a -> b -> c) -> p a b -> p a c
strong f x = dimap (\a -> (a, a)) (\(b, a) -> f a b) (first' x)
instance Strong (->) where
first' ab ~(a, c) = (ab a, c)
{-# INLINE first' #-}
second' ab ~(c, a) = (c, ab a)
{-# INLINE second' #-}
instance Monad m => Strong (Kleisli m) where
first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do
b <- f a
return (b, c)
{-# INLINE first' #-}
second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do
b <- f a
return (c, b)
{-# INLINE second' #-}
instance Functor m => Strong (Star m) where
first' (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a
{-# INLINE first' #-}
second' (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a
{-# INLINE second' #-}
instance Arrow p => Strong (WrappedArrow p) where
first' (WrapArrow k) = WrapArrow (first k)
{-# INLINE first' #-}
second' (WrapArrow k) = WrapArrow (second k)
{-# INLINE second' #-}
instance Strong (Forget r) where
first' (Forget k) = Forget (k . fst)
{-# INLINE first' #-}
second' (Forget k) = Forget (k . snd)
{-# INLINE second' #-}
instance Contravariant f => Strong (Clown f) where
first' (Clown fa) = Clown (contramap fst fa)
{-# INLINE first' #-}
second' (Clown fa) = Clown (contramap snd fa)
{-# INLINE second' #-}
instance (Strong p, Strong q) => Strong (Product p q) where
first' (Pair p q) = Pair (first' p) (first' q)
{-# INLINE first' #-}
second' (Pair p q) = Pair (second' p) (second' q)
{-# INLINE second' #-}
instance (Strong p, Strong q) => Strong (Sum p q) where
first' (L2 p) = L2 (first' p)
first' (R2 q) = R2 (first' q)
{-# INLINE first' #-}
second' (L2 p) = L2 (second' p)
second' (R2 q) = R2 (second' q)
{-# INLINE second' #-}
instance (Functor f, Strong p) => Strong (Tannen f p) where
first' (Tannen fp) = Tannen (fmap first' fp)
{-# INLINE first' #-}
second' (Tannen fp) = Tannen (fmap second' fp)
{-# INLINE second' #-}
newtype Tambara p a b = Tambara { runTambara :: forall c. p (a, c) (b, c) }
instance Profunctor p => Profunctor (Tambara p) where
dimap f g (Tambara p) = Tambara $ dimap (first f) (first g) p
{-# INLINE dimap #-}
instance ProfunctorFunctor Tambara where
promap f (Tambara p) = Tambara (f p)
instance ProfunctorComonad Tambara where
proextract (Tambara p) = dimap (\a -> (a,())) fst p
produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p) where
hither :: ((a, b), c) -> (a, (b, c))
hither ~(~(x,y),z) = (x,(y,z))
yon :: (a, (b, c)) -> ((a, b), c)
yon ~(x,~(y,z)) = ((x,y),z)
instance Profunctor p => Strong (Tambara p) where
first' = runTambara . produplicate
{-# INLINE first' #-}
instance Category p => Category (Tambara p) where
id = Tambara id
Tambara p . Tambara q = Tambara (p . q)
instance Arrow p => Arrow (Tambara p) where
arr f = Tambara $ arr $ first f
first (Tambara f) = Tambara (arr go . first f . arr go) where
go :: ((a, b), c) -> ((a, c), b)
go ~(~(x,y),z) = ((x,z),y)
instance ArrowChoice p => ArrowChoice (Tambara p) where
left (Tambara f) = Tambara (arr yon . left f . arr hither) where
hither :: (Either a b, c) -> Either (a, c) (b, c)
hither (Left y, s) = Left (y, s)
hither (Right z, s) = Right (z, s)
yon :: Either (a, c) (b, c) -> (Either a b, c)
yon (Left (y, s)) = (Left y, s)
yon (Right (z, s)) = (Right z, s)
instance ArrowApply p => ArrowApply (Tambara p) where
app = Tambara $ app . arr (\((Tambara f, x), s) -> (f, (x, s)))
instance ArrowLoop p => ArrowLoop (Tambara p) where
loop (Tambara f) = Tambara (loop (arr go . f . arr go)) where
go :: ((a, b), c) -> ((a, c), b)
go ~(~(x,y),z) = ((x,z),y)
instance ArrowZero p => ArrowZero (Tambara p) where
zeroArrow = Tambara zeroArrow
instance ArrowPlus p => ArrowPlus (Tambara p) where
Tambara f <+> Tambara g = Tambara (f <+> g)
instance Profunctor p => Functor (Tambara p a) where
fmap = rmap
instance (Profunctor p, Arrow p) => Applicative (Tambara p a) where
pure x = arr (const x)
f <*> g = arr (uncurry id) . (f &&& g)
instance (Profunctor p, ArrowPlus p) => Alternative (Tambara p a) where
empty = zeroArrow
f <|> g = f <+> g
instance ArrowPlus p => Semigroup (Tambara p a b) where
f <> g = f <+> g
instance ArrowPlus p => Monoid (Tambara p a b) where
mempty = zeroArrow
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
tambara :: Strong p => (p :-> q) -> p :-> Tambara q
tambara f p = Tambara $ f $ first' p
untambara :: Profunctor q => (p :-> Tambara q) -> p :-> q
untambara f p = dimap (\a -> (a,())) fst $ runTambara $ f p
data Pastro p a b where
Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z)) -> Pastro p a b
instance Profunctor (Pastro p) where
dimap f g (Pastro l m r) = Pastro (g . l) m (r . f)
lmap f (Pastro l m r) = Pastro l m (r . f)
rmap g (Pastro l m r) = Pastro (g . l) m r
w #. Pastro l m r = Pastro (w #. l) m r
Pastro l m r .# w = Pastro l m (r .# w)
instance ProfunctorFunctor Pastro where
promap f (Pastro l m r) = Pastro l (f m) r
instance ProfunctorMonad Pastro where
proreturn p = Pastro fst p $ \a -> (a,())
projoin (Pastro l (Pastro m n o) p) = Pastro lm n op where
op a = case p a of
(b, f) -> case o b of
(c, g) -> (c, (f, g))
lm (d, (f, g)) = l (m (d, g), f)
instance ProfunctorAdjunction Pastro Tambara where
counit (Pastro g (Tambara p) f) = dimap f g p
unit p = Tambara (Pastro id p id)
instance Strong (Pastro p) where
first' (Pastro l m r) = Pastro l' m r' where
r' (a,c) = case r a of
(x,z) -> (x,(z,c))
l' (y,(z,c)) = (l (y,z), c)
second' (Pastro l m r) = Pastro l' m r' where
r' (c,a) = case r a of
(x,z) -> (x,(c,z))
l' (y,(c,z)) = (c,l (y,z))
pastro :: Strong q => (p :-> q) -> Pastro p :-> q
pastro f (Pastro r g l) = dimap l r (first' (f g))
unpastro :: (Pastro p :-> q) -> p :-> q
unpastro f p = f (Pastro fst p (\a -> (a, ())))
class Profunctor p => Costrong p where
unfirst :: p (a, d) (b, d) -> p a b
unfirst = unsecond . dimap swap swap
unsecond :: p (d, a) (d, b) -> p a b
unsecond = unfirst . dimap swap swap
{-# MINIMAL unfirst | unsecond #-}
instance Costrong (->) where
unfirst f a = b where (b, d) = f (a, d)
unsecond f a = b where (d, b) = f (d, a)
instance Functor f => Costrong (Costar f) where
unfirst (Costar f) = Costar f'
where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)
unsecond (Costar f) = Costar f'
where f' fa = b where (d, b) = f ((,) d <$> fa)
instance Costrong Tagged where
unfirst (Tagged bd) = Tagged (fst bd)
unsecond (Tagged db) = Tagged (snd db)
instance ArrowLoop p => Costrong (WrappedArrow p) where
unfirst (WrapArrow k) = WrapArrow (loop k)
instance MonadFix m => Costrong (Kleisli m) where
unfirst (Kleisli f) = Kleisli (liftM fst . mfix . f')
where f' x y = f (x, snd y)
instance Functor f => Costrong (Cokleisli f) where
unfirst (Cokleisli f) = Cokleisli f'
where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)
instance (Functor f, Costrong p) => Costrong (Tannen f p) where
unfirst (Tannen fp) = Tannen (fmap unfirst fp)
unsecond (Tannen fp) = Tannen (fmap unsecond fp)
instance (Costrong p, Costrong q) => Costrong (Product p q) where
unfirst (Pair p q) = Pair (unfirst p) (unfirst q)
unsecond (Pair p q) = Pair (unsecond p) (unsecond q)
instance (Costrong p, Costrong q) => Costrong (Sum p q) where
unfirst (L2 p) = L2 (unfirst p)
unfirst (R2 q) = R2 (unfirst q)
unsecond (L2 p) = L2 (unsecond p)
unsecond (R2 q) = R2 (unsecond q)
data Cotambara q a b where
Cotambara :: Costrong r => (r :-> q) -> r a b -> Cotambara q a b
instance Profunctor (Cotambara p) where
lmap f (Cotambara n p) = Cotambara n (lmap f p)
rmap g (Cotambara n p) = Cotambara n (rmap g p)
dimap f g (Cotambara n p) = Cotambara n (dimap f g p)
instance ProfunctorFunctor Cotambara where
promap f (Cotambara n p) = Cotambara (f . n) p
instance ProfunctorComonad Cotambara where
proextract (Cotambara n p) = n p
produplicate (Cotambara n p) = Cotambara id (Cotambara n p)
instance Costrong (Cotambara p) where
unfirst (Cotambara n p) = Cotambara n (unfirst p)
instance Functor (Cotambara p a) where
fmap = rmap
cotambara :: Costrong p => (p :-> q) -> p :-> Cotambara q
cotambara = Cotambara
uncotambara :: Profunctor q => (p :-> Cotambara q) -> p :-> q
uncotambara f p = proextract (f p)
newtype Copastro p a b = Copastro { runCopastro :: forall r. Costrong r => (forall x y. p x y -> r x y) -> r a b }
instance Profunctor (Copastro p) where
dimap f g (Copastro h) = Copastro $ \ n -> dimap f g (h n)
lmap f (Copastro h) = Copastro $ \ n -> lmap f (h n)
rmap g (Copastro h) = Copastro $ \ n -> rmap g (h n)
instance ProfunctorAdjunction Copastro Cotambara where
unit p = Cotambara id (proreturn p)
counit (Copastro h) = proextract (h id)
instance ProfunctorFunctor Copastro where
promap f (Copastro h) = Copastro $ \n -> h (n . f)
instance ProfunctorMonad Copastro where
proreturn p = Copastro $ \n -> n p
projoin p = Copastro $ \c -> runCopastro p (\x -> runCopastro x c)
instance Costrong (Copastro p) where
unfirst (Copastro p) = Copastro $ \n -> unfirst (p n)
unsecond (Copastro p) = Copastro $ \n -> unsecond (p n)