{-# LANGUAGE CPP #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module Data.Profunctor
(
Profunctor(dimap,lmap,rmap)
, Strong(..)
, Choice(..)
, UpStar(..)
, DownStar(..)
, WrappedArrow(..)
, Forget(..)
) where
import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Category
import Control.Comonad
import Data.Foldable
import Data.Monoid
import Data.Tagged
import Data.Traversable
import Data.Tuple
import Data.Profunctor.Unsafe
import Prelude hiding (id,(.),sequence)
import Unsafe.Coerce
newtype UpStar f d c = UpStar { runUpStar :: d -> f c }
instance Functor f => Profunctor (UpStar f) where
dimap ab cd (UpStar bfc) = UpStar (fmap cd . bfc . ab)
{-# INLINE dimap #-}
lmap k (UpStar f) = UpStar (f . k)
{-# INLINE lmap #-}
rmap k (UpStar f) = UpStar (fmap k . f)
{-# INLINE rmap #-}
p .# _ = unsafeCoerce p
{-# INLINE ( .# ) #-}
instance Functor f => Functor (UpStar f a) where
fmap = rmap
{-# INLINE fmap #-}
newtype DownStar f d c = DownStar { runDownStar :: f d -> c }
instance Functor f => Profunctor (DownStar f) where
dimap ab cd (DownStar fbc) = DownStar (cd . fbc . fmap ab)
{-# INLINE dimap #-}
lmap k (DownStar f) = DownStar (f . fmap k)
{-# INLINE lmap #-}
rmap k (DownStar f) = DownStar (k . f)
{-# INLINE rmap #-}
( #. ) _ = unsafeCoerce
{-# INLINE ( #. ) #-}
instance Functor (DownStar f a) where
fmap k (DownStar f) = DownStar (k . f)
{-# INLINE fmap #-}
newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b }
instance Category p => Category (WrappedArrow p) where
WrapArrow f . WrapArrow g = WrapArrow (f . g)
{-# INLINE (.) #-}
id = WrapArrow id
{-# INLINE id #-}
instance Arrow p => Arrow (WrappedArrow p) where
arr = WrapArrow . arr
{-# INLINE arr #-}
first = WrapArrow . first . unwrapArrow
{-# INLINE first #-}
second = WrapArrow . second . unwrapArrow
{-# INLINE second #-}
WrapArrow a *** WrapArrow b = WrapArrow (a *** b)
{-# INLINE (***) #-}
WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)
{-# INLINE (&&&) #-}
instance ArrowZero p => ArrowZero (WrappedArrow p) where
zeroArrow = WrapArrow zeroArrow
{-# INLINE zeroArrow #-}
instance ArrowChoice p => ArrowChoice (WrappedArrow p) where
left = WrapArrow . left . unwrapArrow
{-# INLINE left #-}
right = WrapArrow . right . unwrapArrow
{-# INLINE right #-}
WrapArrow a +++ WrapArrow b = WrapArrow (a +++ b)
{-# INLINE (+++) #-}
WrapArrow a ||| WrapArrow b = WrapArrow (a ||| b)
{-# INLINE (|||) #-}
instance ArrowApply p => ArrowApply (WrappedArrow p) where
app = WrapArrow $ app . arr (first unwrapArrow)
{-# INLINE app #-}
instance ArrowLoop p => ArrowLoop (WrappedArrow p) where
loop = WrapArrow . loop . unwrapArrow
{-# INLINE loop #-}
instance Arrow p => Profunctor (WrappedArrow p) where
lmap = (^>>)
{-# INLINE lmap #-}
rmap = (^<<)
{-# INLINE rmap #-}
newtype Forget r a b = Forget { runForget :: a -> r }
instance Profunctor (Forget r) where
dimap f _ (Forget k) = Forget (k . f)
{-# INLINE dimap #-}
lmap f (Forget k) = Forget (k . f)
{-# INLINE lmap #-}
rmap _ (Forget k) = Forget k
{-# INLINE rmap #-}
instance Functor (Forget r a) where
fmap _ (Forget k) = Forget k
{-# INLINE fmap #-}
instance Foldable (Forget r a) where
foldMap _ _ = mempty
{-# INLINE foldMap #-}
instance Traversable (Forget r a) where
traverse _ (Forget k) = pure (Forget k)
{-# INLINE traverse #-}
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'
instance Strong (->) where
first' ab ~(a, c) = (ab a, c)
{-# INLINE first' #-}
second' ab ~(c, a) = (c, ab a)
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 (UpStar m) where
first' (UpStar f) = UpStar $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a
{-# INLINE first' #-}
second' (UpStar f) = UpStar $ \ ~(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' #-}
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'
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 (UpStar f) where
left' (UpStar f) = UpStar $ either (fmap Left . f) (fmap Right . pure)
{-# INLINE left' #-}
right' (UpStar f) = UpStar $ either (fmap Left . pure) (fmap Right . f)
{-# INLINE right' #-}
instance Comonad w => Choice (Cokleisli w) where
left' = left
{-# INLINE left' #-}
right' = right
{-# INLINE right' #-}
instance Traversable w => Choice (DownStar w) where
left' (DownStar wab) = DownStar (either Right Left . fmap wab . traverse (either Right Left))
{-# INLINE left' #-}
right' (DownStar wab) = DownStar (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' #-}