#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
#endif
module Data.Profunctor
(
Profunctor(dimap,lmap,rmap)
, Strong(..)
, Choice(..)
, UpStar(..)
, DownStar(..)
, WrappedArrow(..)
) where
import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Category
import Control.Comonad
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)
lmap k (UpStar f) = UpStar (f . k)
rmap k (UpStar f) = UpStar (fmap k . f)
p .# _ = unsafeCoerce p
instance Functor f => Functor (UpStar f a) where
fmap = rmap
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)
lmap k (DownStar f) = DownStar (f . fmap k)
rmap k (DownStar f) = DownStar (k . f)
( #. ) _ = unsafeCoerce
instance Functor (DownStar f a) where
fmap k (DownStar f) = DownStar (k . f)
newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b }
instance Category p => Category (WrappedArrow p) where
WrapArrow f . WrapArrow g = WrapArrow (f . g)
id = WrapArrow id
instance Arrow p => Arrow (WrappedArrow p) where
arr = WrapArrow . arr
first = WrapArrow . first . unwrapArrow
second = WrapArrow . second . unwrapArrow
WrapArrow a *** WrapArrow b = WrapArrow (a *** b)
WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)
instance ArrowZero p => ArrowZero (WrappedArrow p) where
zeroArrow = WrapArrow zeroArrow
instance ArrowChoice p => ArrowChoice (WrappedArrow p) where
left = WrapArrow . left . unwrapArrow
right = WrapArrow . right . unwrapArrow
WrapArrow a +++ WrapArrow b = WrapArrow (a +++ b)
WrapArrow a ||| WrapArrow b = WrapArrow (a ||| b)
instance ArrowApply p => ArrowApply (WrappedArrow p) where
app = WrapArrow $ app . arr (first unwrapArrow)
instance ArrowLoop p => ArrowLoop (WrappedArrow p) where
loop = WrapArrow . loop . unwrapArrow
instance Arrow p => Profunctor (WrappedArrow p) where
lmap = (^>>)
rmap = (^<<)
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)
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)
second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do
b <- f a
return (c, b)
instance Functor m => Strong (UpStar m) where
first' (UpStar f) = UpStar $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a
second' (UpStar f) = UpStar $ \ ~(c, a) -> (,) c <$> f a
instance Arrow p => Strong (WrappedArrow p) where
first' (WrapArrow k) = WrapArrow (first k)
second' (WrapArrow k) = WrapArrow (second k)
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
right' = fmap
instance Monad m => Choice (Kleisli m) where
left' = left
right' = right
instance Comonad w => Choice (Cokleisli w) where
left' = left
right' = right
instance Traversable w => Choice (DownStar w) where
left' (DownStar wab) = DownStar (either Right Left . fmap wab . traverse (either Right Left))
right' (DownStar wab) = DownStar (fmap wab . sequence)
instance Choice Tagged where
left' (Tagged b) = Tagged (Left b)
right' (Tagged b) = Tagged (Right b)
instance ArrowChoice p => Choice (WrappedArrow p) where
left' (WrapArrow k) = WrapArrow (left k)
right' (WrapArrow k) = WrapArrow (right k)