{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708
{-# LANGUAGE Trustworthy #-}
#endif
module Data.Profunctor.Choice
(
Choice(..)
, TambaraSum(..)
, tambaraSum, untambaraSum
, PastroSum(..)
, Cochoice(..)
, CotambaraSum(..)
, cotambaraSum, uncotambaraSum
, CopastroSum(..)
) where
import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Category
import Control.Comonad
import Data.Bifunctor.Joker (Joker(..))
import Data.Bifunctor.Product (Product(..))
import Data.Bifunctor.Tannen (Tannen(..))
import Data.Monoid hiding (Product)
import Data.Profunctor.Adjunction
import Data.Profunctor.Monad
import Data.Profunctor.Strong
import Data.Profunctor.Types
import Data.Profunctor.Unsafe
import Data.Tagged
#if __GLASGOW_HASKELL__ < 710
import Data.Traversable
import Prelude hiding (id,(.),sequence)
#else
import Prelude hiding (id,(.))
#endif
class Profunctor p => Choice p where
left' :: p a b -> p (Either a c) (Either b c)
left' = dimap (either Right Left) (either Right Left) . right'
right' :: p a b -> p (Either c a) (Either c b)
right' = dimap (either Right Left) (either Right Left) . left'
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
{-# MINIMAL left' | right' #-}
#endif
instance Choice (->) where
left' ab (Left a) = Left (ab a)
left' _ (Right c) = Right c
{-# INLINE left' #-}
right' = fmap
{-# INLINE right' #-}
instance Monad m => Choice (Kleisli m) where
left' = left
{-# INLINE left' #-}
right' = right
{-# INLINE right' #-}
instance Applicative f => Choice (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 Comonad w => Choice (Cokleisli w) where
left' = left
{-# INLINE left' #-}
right' = right
{-# INLINE right' #-}
instance Traversable w => Choice (Costar w) where
left' (Costar wab) = Costar (either Right Left . fmap wab . traverse (either Right Left))
{-# INLINE left' #-}
right' (Costar wab) = Costar (fmap wab . sequence)
{-# INLINE right' #-}
instance Choice Tagged where
left' (Tagged b) = Tagged (Left b)
{-# INLINE left' #-}
right' (Tagged b) = Tagged (Right b)
{-# INLINE right' #-}
instance ArrowChoice p => Choice (WrappedArrow p) where
left' (WrapArrow k) = WrapArrow (left k)
{-# INLINE left' #-}
right' (WrapArrow k) = WrapArrow (right k)
{-# INLINE right' #-}
instance Monoid r => Choice (Forget r) where
left' (Forget k) = Forget (either k (const mempty))
{-# INLINE left' #-}
right' (Forget k) = Forget (either (const mempty) k)
{-# INLINE right' #-}
instance Functor f => Choice (Joker f) where
left' (Joker fb) = Joker (fmap Left fb)
{-# INLINE left' #-}
right' (Joker fb) = Joker (fmap Right fb)
{-# INLINE right' #-}
instance (Choice p, Choice q) => Choice (Product p q) where
left' (Pair p q) = Pair (left' p) (left' q)
{-# INLINE left' #-}
right' (Pair p q) = Pair (right' p) (right' q)
{-# INLINE right' #-}
instance (Functor f, Choice p) => Choice (Tannen f p) where
left' (Tannen fp) = Tannen (fmap left' fp)
{-# INLINE left' #-}
right' (Tannen fp) = Tannen (fmap right' fp)
{-# INLINE right' #-}
instance Choice p => Choice (Tambara p) where
left' (Tambara f) = Tambara $ dimap hither yon $ left' f 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)
newtype TambaraSum p a b = TambaraSum { runTambaraSum :: forall c. p (Either a c) (Either b c) }
instance ProfunctorFunctor TambaraSum where
promap f (TambaraSum p) = TambaraSum (f p)
instance ProfunctorComonad TambaraSum where
proextract (TambaraSum p) = dimap Left (\(Left a) -> a) p
produplicate (TambaraSum p) = TambaraSum (TambaraSum $ dimap hither yon p) where
hither :: Either (Either a b) c -> Either a (Either b c)
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)
yon (Right (Right z)) = Right z
instance Profunctor p => Profunctor (TambaraSum p) where
dimap f g (TambaraSum p) = TambaraSum $ dimap (left f) (left g) p
{-# INLINE dimap #-}
instance Profunctor p => Choice (TambaraSum p) where
left' = runTambaraSum . produplicate
{-# INLINE left' #-}
instance Category p => Category (TambaraSum p) where
id = TambaraSum id
TambaraSum p . TambaraSum q = TambaraSum (p . q)
instance Profunctor p => Functor (TambaraSum p a) where
fmap = rmap
tambaraSum :: Choice p => (p :-> q) -> p :-> TambaraSum q
tambaraSum f p = TambaraSum $ f $ left' p
untambaraSum :: Profunctor q => (p :-> TambaraSum q) -> p :-> q
untambaraSum f p = dimap Left (\(Left a) -> a) $ runTambaraSum $ f p
data PastroSum p a b where
PastroSum :: (Either y z -> b) -> p x y -> (a -> Either x z) -> PastroSum p a b
instance Profunctor (PastroSum p) where
dimap f g (PastroSum l m r) = PastroSum (g . l) m (r . f)
lmap f (PastroSum l m r) = PastroSum l m (r . f)
rmap g (PastroSum l m r) = PastroSum (g . l) m r
w #. PastroSum l m r = PastroSum (w #. l) m r
PastroSum l m r .# w = PastroSum l m (r .# w)
instance ProfunctorAdjunction PastroSum TambaraSum where
counit (PastroSum f (TambaraSum g) h) = dimap h f g
unit p = TambaraSum $ PastroSum id p id
instance ProfunctorFunctor PastroSum where
promap f (PastroSum l m r) = PastroSum l (f m) r
instance ProfunctorMonad PastroSum where
proreturn p = PastroSum (\(Left a)-> a) p Left
projoin (PastroSum l (PastroSum m n o) q) = PastroSum lm n oq where
oq a = case q a of
Left b -> Left <$> o b
Right z -> Right (Right z)
lm (Left x) = l $ Left $ m $ Left x
lm (Right (Left y)) = l $ Left $ m $ Right y
lm (Right (Right z)) = l $ Right z
instance Choice (PastroSum p) where
left' (PastroSum l m r) = PastroSum l' m r' where
r' = either (fmap Left . r) (Right . Right)
l' (Left y) = Left (l (Left y))
l' (Right (Left z)) = Left (l (Right z))
l' (Right (Right c)) = Right c
right' (PastroSum l m r) = PastroSum l' m r' where
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))
class Profunctor p => Cochoice p where
unleft :: p (Either a d) (Either b d) -> p a b
unleft = unright . dimap (either Right Left) (either Right Left)
unright :: p (Either d a) (Either d b) -> p a b
unright = unleft . dimap (either Right Left) (either Right Left)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
{-# MINIMAL unleft | unright #-}
#endif
instance Cochoice (->) where
unleft f = go . Left where go = either id (go . Right) . f
unright f = go . Right where go = either (go . Left) id . f
instance Applicative f => Cochoice (Costar f) where
unleft (Costar f) = Costar (go . fmap Left)
where go = either id (go . pure . Right) . f
instance Traversable f => Cochoice (Star f) where
unright (Star f) = Star (go . Right)
where go = either (go . Left) id . sequence . f
instance (Functor f, Cochoice p) => Cochoice (Tannen f p) where
unleft (Tannen fp) = Tannen (fmap unleft fp)
{-# INLINE unleft #-}
unright (Tannen fp) = Tannen (fmap unright fp)
{-# INLINE unright #-}
instance (Cochoice p, Cochoice q) => Cochoice (Product p q) where
unleft (Pair p q) = Pair (unleft p) (unleft q)
unright (Pair p q) = Pair (unright p) (unright q)
data CotambaraSum q a b where
CotambaraSum :: Cochoice r => (r :-> q) -> r a b -> CotambaraSum q a b
instance Profunctor (CotambaraSum p) where
lmap f (CotambaraSum n p) = CotambaraSum n (lmap f p)
rmap g (CotambaraSum n p) = CotambaraSum n (rmap g p)
dimap f g (CotambaraSum n p) = CotambaraSum n (dimap f g p)
instance ProfunctorFunctor CotambaraSum where
promap f (CotambaraSum n p) = CotambaraSum (f . n) p
instance ProfunctorComonad CotambaraSum where
proextract (CotambaraSum n p) = n p
produplicate (CotambaraSum n p) = CotambaraSum id (CotambaraSum n p)
instance Cochoice (CotambaraSum p) where
unleft (CotambaraSum n p) = CotambaraSum n (unleft p)
unright (CotambaraSum n p) = CotambaraSum n (unright p)
instance Functor (CotambaraSum p a) where
fmap = rmap
cotambaraSum :: Cochoice p => (p :-> q) -> p :-> CotambaraSum q
cotambaraSum = CotambaraSum
uncotambaraSum :: Profunctor q => (p :-> CotambaraSum q) -> p :-> q
uncotambaraSum f p = proextract (f p)
newtype CopastroSum p a b = CopastroSum { runCopastroSum :: forall r. Cochoice r => (forall x y. p x y -> r x y) -> r a b }
instance Profunctor (CopastroSum p) where
dimap f g (CopastroSum h) = CopastroSum $ \ n -> dimap f g (h n)
lmap f (CopastroSum h) = CopastroSum $ \ n -> lmap f (h n)
rmap g (CopastroSum h) = CopastroSum $ \ n -> rmap g (h n)
instance ProfunctorAdjunction CopastroSum CotambaraSum where
unit p = CotambaraSum id (proreturn p)
counit (CopastroSum h) = proextract (h id)
instance ProfunctorFunctor CopastroSum where
promap f (CopastroSum h) = CopastroSum $ \n -> h (n . f)
instance ProfunctorMonad CopastroSum where
proreturn p = CopastroSum $ \n -> n p
projoin p = CopastroSum $ \c -> runCopastroSum p (\x -> runCopastroSum x c)
instance Cochoice (CopastroSum p) where
unleft (CopastroSum p) = CopastroSum $ \n -> unleft (p n)
unright (CopastroSum p) = CopastroSum $ \n -> unright (p n)